;;;; the implementation of the programmer's interface to writing
;;;; debugging tools

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB-DI")

;;; FIXME: There are an awful lot of package prefixes in this code.
;;; Couldn't we have SB-DI use the SB-C and SB-VM packages?

;;;; conditions

;;;; The interface to building debugging tools signals conditions that
;;;; prevent it from adhering to its contract. These are
;;;; serious-conditions because the program using the interface must
;;;; handle them before it can correctly continue execution. These
;;;; debugging conditions are not errors since it is no fault of the
;;;; programmers that the conditions occur. The interface does not
;;;; provide for programs to detect these situations other than
;;;; calling a routine that detects them and signals a condition. For
;;;; example, programmers call A which may fail to return successfully
;;;; due to a lack of debug information, and there is no B the they
;;;; could have called to realize A would fail. It is not an error to
;;;; have called A, but it is an error for the program to then ignore
;;;; the signal generated by A since it cannot continue without A's
;;;; correctly returning a value or performing some operation.
;;;;
;;;; Use DEBUG-SIGNAL to signal these conditions.

(define-condition debug-condition (serious-condition)
  ()
  (:documentation
   "All DEBUG-CONDITIONs inherit from this type. These are serious conditions
    that must be handled, but they are not programmer errors."))

(define-condition no-debug-fun-returns (debug-condition)
  ((debug-fun :reader no-debug-fun-returns-debug-fun
              :initarg :debug-fun))
  (:documentation
   "The system could not return values from a frame with DEBUG-FUN since
    it lacked information about returning values.")
  (:report (lambda (condition stream)
             (let ((fun (debug-fun-fun
                         (no-debug-fun-returns-debug-fun condition))))
               (format stream
                       "~&Cannot return values from ~:[frame~;~:*~S~] since ~
                        the debug information lacks details about returning ~
                        values here."
                       fun)))))

(define-condition no-debug-blocks (debug-condition)
  ((debug-fun :reader no-debug-blocks-debug-fun
              :initarg :debug-fun))
  (:documentation "The debug-fun has no debug-block information.")
  (:report (lambda (condition stream)
             (format stream "~&~S has no debug-block information."
                     (no-debug-blocks-debug-fun condition)))))

(define-condition no-debug-vars (debug-condition)
  ((debug-fun :reader no-debug-vars-debug-fun
              :initarg :debug-fun))
  (:documentation "The DEBUG-FUN has no DEBUG-VAR information.")
  (:report (lambda (condition stream)
             (format stream "~&~S has no debug variable information."
                     (no-debug-vars-debug-fun condition)))))

(define-condition lambda-list-unavailable (debug-condition)
  ((debug-fun :reader lambda-list-unavailable-debug-fun
              :initarg :debug-fun))
  (:documentation
   "The DEBUG-FUN has no lambda list since argument DEBUG-VARs are
    unavailable.")
  (:report (lambda (condition stream)
             (format stream "~&~S has no lambda-list information available."
                     (lambda-list-unavailable-debug-fun condition)))))

(define-condition invalid-value (debug-condition)
  ((debug-var :reader invalid-value-debug-var :initarg :debug-var)
   (frame :reader invalid-value-frame :initarg :frame))
  (:report (lambda (condition stream)
             (format stream "~&~S has :invalid or :unknown value in ~S."
                     (invalid-value-debug-var condition)
                     (invalid-value-frame condition)))))

(define-condition ambiguous-var-name (debug-condition)
  ((name :reader ambiguous-var-name-name :initarg :name)
   (frame :reader ambiguous-var-name-frame :initarg :frame))
  (:report (lambda (condition stream)
             (format stream "~&~S names more than one valid variable in ~S."
                     (ambiguous-var-name-name condition)
                     (ambiguous-var-name-frame condition)))))

;;;; errors and DEBUG-SIGNAL

;;; The debug-internals code tries to signal all programmer errors as
;;; subtypes of DEBUG-ERROR. There are calls to ERROR signalling
;;; SIMPLE-ERRORs, but these dummy checks in the code and shouldn't
;;; come up.
;;;
;;; While under development, this code also signals errors in code
;;; branches that remain unimplemented.

(define-condition debug-error (error) ()
  (:documentation
   "All programmer errors from using the interface for building debugging
    tools inherit from this type."))

(define-condition unhandled-debug-condition (debug-error)
  ((condition :reader unhandled-debug-condition-condition :initarg :condition))
  (:report (lambda (condition stream)
             (format stream "~&unhandled DEBUG-CONDITION:~%~A"
                     (unhandled-debug-condition-condition condition)))))

(define-condition unknown-code-location (debug-error)
  ((code-location :reader unknown-code-location-code-location
                  :initarg :code-location))
  (:report (lambda (condition stream)
             (format stream "~&invalid use of an unknown code-location: ~S"
                     (unknown-code-location-code-location condition)))))

(define-condition unknown-debug-var (debug-error)
  ((debug-var :reader unknown-debug-var-debug-var :initarg :debug-var)
   (debug-fun :reader unknown-debug-var-debug-fun
              :initarg :debug-fun))
  (:report (lambda (condition stream)
             (format stream "~&~S is not in ~S."
                     (unknown-debug-var-debug-var condition)
                     (unknown-debug-var-debug-fun condition)))))

(define-condition invalid-control-stack-pointer (debug-error)
  ()
  (:report (lambda (condition stream)
             (declare (ignore condition))
             (fresh-line stream)
             (write-string "invalid control stack pointer" stream))))

(define-condition frame-fun-mismatch (debug-error)
  ((code-location :reader frame-fun-mismatch-code-location
                  :initarg :code-location)
   (frame :reader frame-fun-mismatch-frame :initarg :frame)
   (form :reader frame-fun-mismatch-form :initarg :form))
  (:report (lambda (condition stream)
             (format
              stream
              "~&Form was preprocessed for ~S,~% but called on ~S:~%  ~S"
              (frame-fun-mismatch-code-location condition)
              (frame-fun-mismatch-frame condition)
              (frame-fun-mismatch-form condition)))))

;;; This signals debug-conditions. If they go unhandled, then signal
;;; an UNHANDLED-DEBUG-CONDITION error.
;;;
;;; ??? Get SIGNAL in the right package!
(defmacro debug-signal (datum &rest arguments)
  `(let ((condition (make-condition ,datum ,@arguments)))
     (signal condition)
     (error 'unhandled-debug-condition :condition condition)))

;;;; structures
;;;;
;;;; Most of these structures model information stored in internal
;;;; data structures created by the compiler. Whenever comments
;;;; preface an object or type with "compiler", they refer to the
;;;; internal compiler thing, not to the object or type with the same
;;;; name in the "SB-DI" package.

;;;; DEBUG-VARs

;;; These exist for caching data stored in packed binary form in
;;; compiler DEBUG-FUNs.
(defstruct (debug-var (:constructor nil)
                      (:copier nil))
  ;; the name of the variable
  (symbol (missing-arg) :type symbol)
  ;; a unique integer identification relative to other variables with the same
  ;; symbol
  (id 0 :type index :read-only t)
  ;; Does the variable always have a valid value?
  (alive-p nil :type boolean :read-only t))
(defmethod print-object ((debug-var debug-var) stream)
  (print-unreadable-object (debug-var stream :type t :identity t)
    (format stream
            "~S ~W"
            (debug-var-symbol debug-var)
            (debug-var-id debug-var))))

(setf (documentation 'debug-var-id 'function)
  "Return the integer that makes DEBUG-VAR's name and package unique
   with respect to other DEBUG-VARs in the same function.")

(defstruct (compiled-debug-var
            (:include debug-var)
            (:constructor make-compiled-debug-var
                (symbol id alive-p
                 sc+offset save-sc+offset indirect-sc+offset info))
            (:copier nil))
  ;; storage class and offset (unexported)
  (sc+offset nil :type sb-c:sc+offset :read-only t)
  ;; storage class and offset when saved somewhere
  (save-sc+offset nil :type (or sb-c:sc+offset null) :read-only t)
  ;; For indirect closures the fp of the parent frame is stored in the
  ;; normal SC+OFFSETs above, and this has the offset into the frame
  (indirect-sc+offset nil :type (or sb-c:sc+offset null) :read-only t)
  (info nil :read-only t))

;;;; DEBUG-FUNs

;;; These exist for caching data stored in packed binary form in
;;; compiler DEBUG-FUNs. *COMPILED-DEBUG-FUNS* maps a SB-C::DEBUG-FUN
;;; to a DEBUG-FUN. There should only be one DEBUG-FUN in existence
;;; for any function; that is, all CODE-LOCATIONs and other objects
;;; that reference DEBUG-FUNs point to unique objects. This is
;;; due to the overhead in cached information.

(defstruct (debug-fun (:constructor nil)
                      (:copier nil))
  ;; some representation of the function arguments. See
  ;; DEBUG-FUN-LAMBDA-LIST.
  ;; NOTE: must parse vars before parsing arg list stuff.
  (%lambda-list :unparsed)
  ;; cached DEBUG-VARS information (unexported).
  ;; These are sorted by their name.
  (%debug-vars :unparsed :type (or simple-vector null (member :unparsed)))
  ;; cached debug-block information. This is NIL when we have tried to
  ;; parse the packed binary info, but none is available.
  (blocks :unparsed :type (or simple-vector null (member :unparsed)))
  ;; the actual function if available
  (%function :unparsed :type (or null function (member :unparsed))))
(defmethod print-object ((obj debug-fun) stream)
  (print-unreadable-object (obj stream :type t)
    (prin1 (debug-fun-name obj) stream)))

(defstruct (bogus-debug-fun
            (:include debug-fun)
            (:constructor make-bogus-debug-fun
                          (%name &aux
                                 (%lambda-list nil)
                                 (%debug-vars nil)
                                 (blocks nil)
                                 (%function nil)))
            (:copier nil))
  (%name nil :read-only t))

;;;; DEBUG-BLOCKs

;;; These exist for caching data stored in packed binary form in compiler
;;; DEBUG-BLOCKs.
(defstruct (debug-block (:constructor nil)
                        (:copier nil))
  ;; This indicates whether the block is a special glob of code shared
  ;; by various functions and tucked away elsewhere in a component.
  ;; This kind of block has no start code-location. This slot is in
  ;; all debug-blocks since it is an exported interface.
  (elsewhere-p nil :type boolean))
(defmethod print-object ((obj debug-block) str)
  (print-unreadable-object (obj str :type t)
    (prin1 (debug-block-fun-name obj) str)))

(setf (documentation 'debug-block-elsewhere-p 'function)
  "Return whether debug-block represents elsewhere code.")

(defstruct (compiled-debug-block (:include debug-block)
                                 (:copier nil))
  ;; code-location information for the block
  (code-locations #() :type simple-vector))

(defstruct (code-location (:constructor nil)
                          (:copier nil))
  ;; the DEBUG-FUN containing this CODE-LOCATION
  (debug-fun nil :type debug-fun :read-only t)
  ;; This is initially :UNSURE. Upon first trying to access an
  ;; :UNPARSED slot, if the data is unavailable, then this becomes T,
  ;; and the code-location is unknown. If the data is available, this
  ;; becomes NIL, a known location. We can't use a separate type
  ;; code-location for this since we must return code-locations before
  ;; we can tell whether they're known or unknown. For example, when
  ;; parsing the stack, we don't want to unpack all the variables and
  ;; blocks just to make frames.
  (%unknown-p :unsure :type (member t nil :unsure))
  ;; the DEBUG-BLOCK containing CODE-LOCATION. XXX Possibly toss this
  ;; out and just find it in the blocks cache in DEBUG-FUN.
  (%debug-block :unparsed :type (or debug-block (member :unparsed)))
  ;; This is the depth-first number of the node that begins
  ;; code-location within its top level form.
  (%form-number :unparsed :type (or index (member :unparsed))))

;;;; frames

;;; These represent call frames on the stack.
(defstruct (frame (:constructor nil)
                  (:copier nil))
  ;; the next frame up, or NIL when top frame
  ;; KLUDGE - (OR NULL FRAME), and not (OR FRAME NULL), because PARSE-1-DSD
  ;; warns; we're so bad at understanding recursive structure.
  (up nil :type (or null frame))
  ;; the previous frame down, or NIL when the bottom frame. Before
  ;; computing the next frame down, this slot holds the frame pointer
  ;; to the control stack for the given frame. This lets us get the
  ;; next frame down and the return-pc for that frame.
  (%down :unparsed :type (or (member nil :unparsed) frame))
  ;; the DEBUG-FUN for the function whose call this frame represents
  (debug-fun nil :type debug-fun :read-only t)
  ;; the CODE-LOCATION where the frame's DEBUG-FUN will continue
  ;; running when program execution returns to this frame. If someone
  ;; interrupted this frame, the result could be an unknown
  ;; CODE-LOCATION.
  (code-location nil :type code-location :read-only t)
  ;; an a-list of catch-tags to code-locations
  (%catches :unparsed :type (or list (member :unparsed)))
  ;; pointer to frame on control stack (unexported)
  (pointer nil :read-only t)
  ;; This is the frame's number for prompt printing. Top is zero.
  (number 0 :type index))

(defstruct (compiled-frame
            (:include frame)
            (:constructor make-compiled-frame
                          (pointer up debug-fun code-location number
                                   &optional escaped))
            (:copier nil))
  ;; This indicates whether someone interrupted the frame.
  ;; (unexported). If escaped, this is a pointer to the state that was
  ;; saved when we were interrupted, an os_context_t, i.e. the third
  ;; argument to an SA_SIGACTION-style signal handler.
  (escaped nil :read-only t))
(defmethod print-object ((obj compiled-frame) str)
  (print-unreadable-object (obj str :type t)
    (format str
            "~S~:[~;, interrupted~]"
            (debug-fun-name (frame-debug-fun obj))
            (compiled-frame-escaped obj))))


;;; This maps SB-C::COMPILED-DEBUG-FUNs to
;;; COMPILED-DEBUG-FUNs, so we can get at cached stuff and not
;;; duplicate COMPILED-DEBUG-FUN structures.
#+cheneygc ; can't write to debug-info in a purified code object
(define-load-time-global *compiled-debug-funs*
    (make-hash-table :test 'eq :weakness :key))

;;;; breakpoints

;;; This is an internal structure that manages information about a
;;; breakpoint locations. See *COMPONENT-BREAKPOINT-OFFSETS*.
(defstruct (breakpoint-data (:constructor make-breakpoint-data
                                          (component offset))
                            (:copier nil))
  ;; This is the component in which the breakpoint lies.
  (component nil :read-only t)
  ;; This is the byte offset into the component.
  (offset nil :type index :read-only t)
  ;; The original instruction replaced by the breakpoint.
  (instruction nil :type (or null sb-vm:word))
  ;; A list of user breakpoints at this location.
  (breakpoints nil :type list))
(defmethod print-object ((obj breakpoint-data) str)
  (print-unreadable-object (obj str :type t)
    (format str "~S at ~S"
            (debug-fun-name
             (debug-fun-from-pc (breakpoint-data-component obj)
                                (breakpoint-data-offset obj)))
            (breakpoint-data-offset obj))))

(defstruct (breakpoint (:constructor %make-breakpoint
                                     (hook-fun what kind %info))
                       (:copier nil))
  ;; This is the function invoked when execution encounters the
  ;; breakpoint. It takes a frame, the breakpoint, and optionally a
  ;; list of values. Values are supplied for :FUN-END breakpoints as
  ;; values to return for the function containing the breakpoint.
  ;; :FUN-END breakpoint hook functions also take a cookie argument.
  ;; See the COOKIE-FUN slot.
  (hook-fun (required-arg) :type function)
  ;; CODE-LOCATION or DEBUG-FUN
  (what nil :type (or code-location debug-fun) :read-only t)
  ;; :CODE-LOCATION, :FUN-START, or :FUN-END for that kind
  ;; of breakpoint. :UNKNOWN-RETURN-PARTNER if this is the partner of
  ;; a :code-location breakpoint at an :UNKNOWN-RETURN code-location.
  (kind nil :type (member :code-location :fun-start :fun-end
                          :unknown-return-partner)
            :read-only t)
  ;; Status helps the user and the implementation.
  (status :inactive :type (member :active :inactive :deleted))
  ;; This is a backpointer to a breakpoint-data.
  (internal-data nil :type (or null breakpoint-data))
  ;; With code-locations whose type is :UNKNOWN-RETURN, there are
  ;; really two breakpoints: one at the multiple-value entry point,
  ;; and one at the single-value entry point. This slot holds the
  ;; breakpoint for the other one, or NIL if this isn't at an
  ;; :UNKNOWN-RETURN code location.
  (unknown-return-partner nil :type (or null breakpoint))
  ;; :FUN-END breakpoints use a breakpoint at the :FUN-START
  ;; to establish the end breakpoint upon function entry. We do this
  ;; by frobbing the LRA to jump to a special piece of code that
  ;; breaks and provides the return values for the returnee. This slot
  ;; points to the start breakpoint, so we can activate, deactivate,
  ;; and delete it.
  (start-helper nil :type (or null breakpoint))
  ;; This is a hook users supply to get a dynamically unique cookie
  ;; for identifying :FUN-END breakpoint executions. That is, if
  ;; there is one :FUN-END breakpoint, but there may be multiple
  ;; pending calls of its function on the stack. This function takes
  ;; the cookie, and the hook function takes the cookie too.
  (cookie-fun nil :type (or null function))
  ;; This slot users can set with whatever information they find useful.
  (%info nil))
(defmethod print-object ((obj breakpoint) str)
  (let ((what (breakpoint-what obj)))
    (print-unreadable-object (obj str :type t)
      (format str
              "~S~:[~;~:*~S~]"
              (etypecase what
                (code-location what)
                (debug-fun (debug-fun-name what)))
              (etypecase what
                (code-location nil)
                (debug-fun (breakpoint-kind obj)))))))

(defstruct (compiled-debug-fun
            (:include debug-fun)
            (:constructor %make-compiled-debug-fun
                          (compiler-debug-fun component))
            (:copier nil))
  ;; compiler's dumped DEBUG-FUN information (unexported)
  (compiler-debug-fun nil :type sb-c::compiled-debug-fun
                          :read-only t)
  ;; code object (unexported).
  (component nil :read-only t)
  ;; the :FUN-START breakpoint (if any) used to facilitate
  ;; function end breakpoints
  (end-starter nil :type (or null breakpoint)))

;;; Map a SB-C::COMPILED-DEBUG-FUN to a SB-DI::COMPILED-DEBUG-FUN.
;;; The mapping is memoized into a slot of %CODE-DEBUG-INFO of COMPONENT
;;; except on #+cheneygc where that is assumed not to be possible
;;; (even if it is possible), because usually it's not, because
;;; code and the debug structures are defined with :PURE T and might reside
;;; in readonly space, which can only have pointers to static space.
;;;
;;; BTW, the nomenclature here is utter and total confusion.
;;; The type of the object in the argument named COMPILER-DEBUG-FUN
;;; is SB-C::COMPILED-DEBUG-FUN.
;;; There is no such type as a "COMPILER-DEBUG-FUN", it's just the name
;;; of the slot in the SB-DI:: version of the structure.
(defun make-compiled-debug-fun (compiler-debug-fun component)
  (declare (code-component component))
  #+gencgc
  (let ((memo-cell
         (let* ((info (sb-vm::%%code-debug-info component))
                (val (sb-c::compiled-debug-info-tlf-num+offset info)))
           (if (consp val)
               val
               (let* ((list (list val))
                      (old (cas (sb-c::compiled-debug-info-tlf-num+offset info) val list)))
                 (if (eq old val) list old))))))
    ;; The CDR of TLF-NUM+OFFSET slot is an alist from compiler -> debugger structure.
    (let ((new-df nil) (new-pair nil) (new-alist nil) (alist (cdr memo-cell)))
      (loop
        ;; This list generally contains 5 items or less. At least, in our tests it does
        ;; which I assume is typical.
        (awhen (assoc compiler-debug-fun alist :test #'eq) (return (cdr it)))
        (if new-alist
            (rplacd new-alist alist)
            (setq new-df (%make-compiled-debug-fun compiler-debug-fun component)
                  new-pair (cons compiler-debug-fun new-df)
                  new-alist (cons new-pair alist)))
        (let ((old (cas (cdr memo-cell) alist new-alist)))
          (if (eq old alist) (return new-df) (setq alist old))))))
  #+cheneygc
  (ensure-gethash compiler-debug-fun *compiled-debug-funs*
                  (%make-compiled-debug-fun compiler-debug-fun component)))

;;;; CODE-LOCATIONs

(defmethod print-object ((obj code-location) str)
  (print-unreadable-object (obj str :type t)
    (prin1 (debug-fun-name (code-location-debug-fun obj))
           str)))

(defstruct (compiled-code-location
             (:include code-location)
             (:constructor make-known-code-location
                           (pc debug-fun %debug-block %form-number
                               %live-set kind step-info context &aux (%unknown-p nil)))
             (:constructor make-compiled-code-location (pc debug-fun))
             (:copier nil))
  ;; an index into DEBUG-FUN's component slot
  (pc nil :type index :read-only t)
  ;; a bit-vector indexed by a variable's position in
  ;; DEBUG-FUN-DEBUG-VARS indicating whether the variable has a
  ;; valid value at this code-location. (unexported).
  (%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
  ;; (unexported) To see SB-C::LOCATION-KIND, do
  ;; (SB-KERNEL:TYPEXPAND 'SB-C::LOCATION-KIND).
  (kind :unparsed :type (or (member :unparsed) sb-c::location-kind))
  (step-info :unparsed :type (or (member :unparsed :foo) simple-string))
  (context :unparsed))

;;;; frames

;;; This is used in FIND-ESCAPED-FRAME and with the "breakpoint return" objects
;;; and LRAs used for :FUN-END breakpoints. When a code object's
;;; debug-info slot is :BPT-LRA, then the REAL-LRA-SLOT contains the
;;; real location to continue executing, as opposed to the intermediary object
;;; which appeared in some frame's LRA location.
;;; NB: If you change change REAL-LRA-SLOT, then you must also change
;;; "#define REAL_LRA_SLOT" in breakpoint.c. These have unfortunately
;;; different values, because this slot is relative to the object base
;;; address, whereas the one in C is an index into code->constants.
(defconstant real-lra-slot sb-vm:code-constants-offset)

(declaim (inline control-stack-pointer-valid-p))
(defun control-stack-pointer-valid-p (x &optional (aligned t))
  (declare (type system-area-pointer x))
  (let* (#-stack-grows-downward-not-upward
         (control-stack-start
          (descriptor-sap *control-stack-start*))
         #+stack-grows-downward-not-upward
         (control-stack-end
          (descriptor-sap *control-stack-end*)))
    #-stack-grows-downward-not-upward
    (and (sap< x (current-sp))
         (sap<= control-stack-start x)
         (or (not aligned) (zerop (logand (sap-int x)
                                          (1- (ash 1 sb-vm:word-shift))))))
    #+stack-grows-downward-not-upward
    (and (sap>= x (current-sp))
         (sap> control-stack-end x)
         (or (not aligned) (zerop (logand (sap-int x)
                                          (1- (ash 1 sb-vm:word-shift))))))))

(declaim (inline valid-lisp-pointer-p))
(sb-alien:define-alien-routine valid-lisp-pointer-p sb-alien:int
  (pointer system-area-pointer))

;;; There are many opportunities for things to go wrong when searching
;;; the heap for a code component. One possible problem occurs when
;;; component_ptr_from_pc() searches for a code component on a page which
;;; gets partially evacuated on x86[-64]. Suppose it contains pinned code
;;; preceded by some objects that got forwarded. The scan performed by
;;; gc_search_space could be interrupted in the middle, and resume execution
;;; looking at a forwarding pointer, which gets the fatal "no size function".
;;; Morover, excess delay between finding an object and creating a Lisp
;;; descriptor introduces additional potential for error.
;;; So we do two things to mitigate that problem:
;;; (1) use unsafe %MAKE-LISP-OBJ, since we've already determined
;;;     where the code object starts with certainty, and we don't need
;;;     yet another search to test validity of the address.
;;; (2) wrap the calls in WITHOUT-GCING.
;;;
;;; Here's a concrete example, assuming the following objects exists:
;;;       0x8000: vector header     |
;;;       0x8008: vector length     | object 1
;;;       0x8010: vector contents   |
;;;             : ...               v
;;;       0x8100: code object       | object 2
;;;             : ...
;;; thread A is backtracing, and currently in component_ptr_to_pc(),
;;; looking at 0x8000. Suppose the code is pinned, and that a garbage collection
;;; will partially evacuate the page, and that partial evacuation zero-fills
;;; the unused ranges (which it no longer does). Consider these schedules:
;;;
;;;  Thread A                      Thread B
;;;  --------                      --------
;;;  read header @ 0x8000
;;;                                 GC happens. zero-fill from 0x8000:0x8100
;;;  read length @ 0x8008 => 0
;;;   (skip to next object)
;;;  read header @ 0x8010 => junk
;;;
;;; In this schedule, thread A reads a word which is not a valid object header.
;;;
;;; But partial evacution no longer zeros the freed subranges - instead it writes
;;; an unboxed array header so that only two words are touched per unused subrange.
;;; This causes a different problem: The array may appear to contain forwarding
;;; pointers to live objects that were moved off the page, and those pointers
;;; appear to be embedded in the unboxed array.
;;;
;;; Use of WITHOUT-GCING is unfortunate - it's always preferable to
;;; try to pin individual objects - but to do better we would have to
;;; implement page-wide hazard pointers informing GC not to do anything
;;; to any object on a specified page.
;;;
;;; On top of the considerations about dynamic space, there is a further issue
;;; with allocatin of immobile code. The allocator creates transient inconsistent
;;; states when it reuses holes. Even if the header could be written atomically,
;;; there can be junk in the remaining bytes of the hole that gets rewritten as
;;; a smaller hole. It's evident that acquiring the allocator mutex works around
;;; that glitch, as without such precaution, 'compiler.pure.lisp' would routinely
;;; crash when run in multiple threads. A better fix would be to preseve invariants
;;; at all times when allocating, both for the new hole that results from the hole
;;; that gets cut down to size, and for the new object per se. Example:
;;;    | hole ............................ |  1 Kb
;;;      ^ new-object here  ^ smaller hole starts here
;;;        (512 bytes)
;;;
;;; We first need to atomically write the header of the smaller hole
;;; (which can't even be seen until the new object header is written).
;;; This establishes that there won't be an inconsistent state.
;;; Then we need to atomically write the new object header.
;;; I suspect that both atomic writes should use double-wide CAS,
;;; because if the object header is written using lispword-sized writes,
;;; then the object can be sized wrong, and in this case it does cause problems
;;; because the remaining bytes are not zero-filled. The allocator is similar
;;; to malloc() in that regard.

(defun code-header-from-pc (pc)
  (declare (system-area-pointer pc))
  (with-code-pages-pinned (:dynamic)
    (let ((base-ptr
           (sb-alien:alien-funcall
            (sb-alien:extern-alien "component_ptr_from_pc"
                                   (function sb-alien:unsigned system-area-pointer))
            pc)))
      (unless (= base-ptr 0)
        (%make-lisp-obj (logior base-ptr sb-vm:other-pointer-lowtag))))))

;;;; (OR X86 X86-64) support

#+(or x86 x86-64)
(progn

(defun compute-lra-data-from-pc (pc)
  (declare (type system-area-pointer pc))
  ;; While theoretically we should inhibit GC any time we search the heap,
  ;; in practice this function can only be called for code that is somewhere
  ;; on the stack, and therefore conservatively pinned.
  (let ((code (code-header-from-pc pc)))
    (values (if code (sap- pc (code-instructions code)) nil)
            code)))

;;; Check for a valid return address - it could be any valid C/Lisp
;;; address.
;;;
;;; XXX Could be a little smarter.
(declaim (inline ra-pointer-valid-p))
(defun ra-pointer-valid-p (ra)
  (declare (type system-area-pointer ra))
  (and
   ;; not the first page (which is unmapped)
   ;;
   ;; FIXME: Where is this documented? Is it really true of every CPU
   ;; architecture? Is it even necessarily true in current SBCL?
   (>= (sap-int ra) 4096)
   ;; not a Lisp stack pointer
   (not (control-stack-pointer-valid-p ra))))

;;; Try to find a valid previous stack. This is complex on the x86 as
;;; it can jump between C and Lisp frames. To help find a valid frame
;;; it searches backwards.
;;;
;;; XXX Should probably check whether it has reached the bottom of the
;;; stack.
;;;
;;; XXX Should handle interrupted frames, both Lisp and C. At present
;;; it manages to find a fp trail, see linux hack below.
(declaim (maybe-inline x86-call-context))
(defun x86-call-context (fp)
  (declare (type system-area-pointer fp))
  (let ((ocfp (sap-ref-sap fp (sb-vm::frame-byte-offset ocfp-save-offset)))
        (ra (sap-ref-sap fp (sb-vm::frame-byte-offset return-pc-save-offset))))
    (if (and (control-stack-pointer-valid-p fp)
             (sap> ocfp fp)
             (control-stack-pointer-valid-p ocfp)
             (ra-pointer-valid-p ra))
        (values t ra ocfp)
        (values nil (int-sap 0) (int-sap 0)))))

) ; #+x86 PROGN

;;; Return the top frame of the control stack as it was before calling
;;; this function.
(defun top-frame ()
  (/noshow0 "entering TOP-FRAME")
  (compute-calling-frame (descriptor-sap (%caller-frame))
                         (%caller-pc)
                         nil))

;;; Flush all of the frames above FRAME, and renumber all the frames
;;; below FRAME.
(defun flush-frames-above (frame)
  (setf (frame-up frame) nil)
  (do ((number 0 (1+ number))
       (frame frame (frame-%down frame)))
      ((not (frame-p frame)))
    (setf (frame-number frame) number)))

#+(or x86 x86-64)
(defun find-saved-frame-down (fp up-frame)
  (multiple-value-bind (saved-fp saved-pc)
      (find-saved-fp-and-pc fp)
    (when saved-fp
      (compute-calling-frame saved-fp saved-pc up-frame t))))

(defun walk-binding-stack (symbol function)
  (let* (#+sb-thread
         (tls-index (symbol-tls-index symbol))
         (current-value
           #+sb-thread
           (sap-ref-lispobj (sb-thread::current-thread-sap) tls-index)
           #-sb-thread
           (symbol-value symbol)))
    (unless (eq (get-lisp-obj-address current-value)
                no-tls-value-marker-widetag)
      (funcall function current-value)
      (loop for start = (descriptor-sap *binding-stack-start*)
            for pointer = (descriptor-sap sb-vm::*binding-stack-pointer*)
            then (sap+ pointer (* n-word-bytes -2))
            while (sap> pointer start)
            when
            #+sb-thread (eq (sap-ref-word pointer (* n-word-bytes -1)) tls-index)
            #-sb-thread (eq (sap-ref-lispobj pointer (* n-word-bytes -1)) symbol)
            do (unless (or #+sb-thread
                           (= (sap-ref-word pointer (* n-word-bytes -2))
                              no-tls-value-marker-widetag))
                 (funcall function
                          (sap-ref-lispobj pointer
                                           (* n-word-bytes -2))))))))

#+c-stack-is-control-stack
(defun find-saved-fp-and-pc (fp)
  (block nil
    (walk-binding-stack
     'sb-alien-internals:*saved-fp*
     (lambda (x)
       (when x
         (let* ((saved-fp (descriptor-sap x))
                (caller-fp (sap-ref-sap saved-fp
                                        (sb-vm::frame-byte-offset
                                         ocfp-save-offset))))
           (when (#+stack-grows-downward-not-upward
                  sap>
                  #-stack-grows-downward-not-upward
                  sap<
                  caller-fp fp)
             (return (values caller-fp
                             (sap-ref-sap saved-fp
                                          (sb-vm::frame-byte-offset
                                           return-pc-save-offset)))))))))))

(defun return-pc-offset-for-location (debug-fun location)
  (declare (ignorable debug-fun location))
  #+fp-and-pc-standard-save
  sb-c:return-pc-passing-offset
  #-fp-and-pc-standard-save
  (etypecase debug-fun
    (compiled-debug-fun
     (let ((c-d-f (compiled-debug-fun-compiler-debug-fun debug-fun))
           (pc-offset (compiled-code-location-pc location)))
       (if (>= pc-offset (sb-c::compiled-debug-fun-lra-saved-pc c-d-f))
           (sb-c::compiled-debug-fun-return-pc c-d-f)
           (sb-c::compiled-debug-fun-return-pc-pass c-d-f))))
    (bogus-debug-fun
     ;; No handy backend (or compiler) defined constant for this one,
     ;; so construct it here and now.
     (sb-c:make-sc+offset control-stack-sc-number lra-save-offset))))

(defun old-fp-offset-for-location (debug-fun location)
  (declare (ignorable debug-fun location))
  #+fp-and-pc-standard-save
  sb-c:old-fp-passing-offset
  #-fp-and-pc-standard-save
  (etypecase debug-fun
    (compiled-debug-fun
     (let ((c-d-f (compiled-debug-fun-compiler-debug-fun debug-fun))
           (pc-offset (compiled-code-location-pc location)))
       (if (>= pc-offset (sb-c::compiled-debug-fun-cfp-saved-pc c-d-f))
           (sb-c::compiled-debug-fun-old-fp c-d-f)
           sb-c:old-fp-passing-offset)))
    (bogus-debug-fun
     ;; No handy backend (or compiler) defined constant for this one,
     ;; so construct it here and now.
     (sb-c:make-sc+offset control-stack-sc-number ocfp-save-offset))))

(defun frame-saved-cfp (frame debug-fun)
  (sub-access-debug-var-slot
   (frame-pointer frame)
   (old-fp-offset-for-location debug-fun (frame-code-location frame))
   (compiled-frame-escaped frame)))

(defun frame-saved-lra (frame debug-fun)
  (sub-access-debug-var-slot
   (frame-pointer frame)
   (return-pc-offset-for-location debug-fun (frame-code-location frame))
   (compiled-frame-escaped frame)))

(defun (setf frame-saved-lra) (new-lra frame debug-fun)
  (sub-set-debug-var-slot
   (frame-pointer frame)
   (return-pc-offset-for-location debug-fun (frame-code-location frame))
   new-lra
   (compiled-frame-escaped frame))
  new-lra)

;;; Return the frame immediately below FRAME on the stack; or when
;;; FRAME is the bottom of the stack, return NIL.
(defun frame-down (frame)
  (/noshow0 "entering FRAME-DOWN")
  ;; We have to access the old-fp and return-pc out of frame and pass
  ;; them to COMPUTE-CALLING-FRAME.
  (let ((down (frame-%down frame)))
    (if (eq down :unparsed)
        (let ((debug-fun (frame-debug-fun frame)))
          (/noshow0 "in DOWN :UNPARSED case")
          (setf (frame-%down frame)
                (etypecase debug-fun
                  ((or compiled-debug-fun
                       #-(or x86 x86-64) bogus-debug-fun)
                   (compute-calling-frame
                    (descriptor-sap (frame-saved-cfp frame debug-fun))
                    (frame-saved-lra frame debug-fun)
                    frame))
                  #+(or x86 x86-64)
                  (bogus-debug-fun
                   (let ((fp (frame-pointer frame)))
                     (when (control-stack-pointer-valid-p fp)
                       (multiple-value-bind (ok ra ofp) (x86-call-context fp)
                         (if ok
                             (compute-calling-frame ofp ra frame)
                             (find-saved-frame-down fp frame)))))))))
        down)))

(defun foreign-function-backtrace-name (sap)
  (let ((name (sap-foreign-symbol sap)))
    (if name
        (format nil "foreign function: ~A" name)
        (format nil "foreign function: #x~X" (sap-int sap)))))

;;; This returns a frame for the one existing in time immediately
;;; prior to the frame referenced by current-fp. This is current-fp's
;;; caller or the next frame down the control stack. If there is no
;;; down frame, this returns NIL for the bottom of the stack. UP-FRAME
;;; is the up link for the resulting frame object, and it is null when
;;; we call this to get the top of the stack.
;;;
;;; The current frame contains the pointer to the temporally previous
;;; frame we want, and the current frame contains the pc at which we
;;; will continue executing upon returning to that previous frame.
;;;
;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
;;; calls into C. In this case, the code object is stored on the stack
;;; after the LRA, and the LRA is the word offset.
#-(or x86 x86-64)
(defun compute-calling-frame (caller lra up-frame &optional savedp)
  (declare (type system-area-pointer caller)
           (ignore savedp))
  (/noshow0 "entering COMPUTE-CALLING-FRAME")
  (when (control-stack-pointer-valid-p caller)
    (/noshow0 "in WHEN")
    (multiple-value-bind (code pc-offset escaped)
        (if lra
            (multiple-value-bind (word-offset code)
                (if (fixnump lra)
                    (let ((fp (frame-pointer up-frame)))
                      (values lra
                              (let ((code (stack-ref fp (1+ lra-save-offset))))
                                code
                                #+ppc64
                                (%make-lisp-obj (logior (ash code n-fixnum-tag-bits)
                                                        other-pointer-lowtag)))))
                    (values (get-header-data lra)
                            (lra-code-header lra)))
              (if code
                  (values code
                          (* (1+ (- word-offset (code-header-words code)))
                             sb-vm:n-word-bytes)
                          nil)
                  (values :foreign-function
                          0
                          nil)))
            (find-escaped-frame caller))
      (if (and (code-component-p code)
               (eq (%code-debug-info code) :bpt-lra))
          (let ((real-lra (code-header-ref code real-lra-slot)))
            (compute-calling-frame caller real-lra up-frame))
          (let ((d-fun (case code
                         (:undefined-function
                          (make-bogus-debug-fun
                           "undefined function"))
                         (:foreign-function
                          (make-bogus-debug-fun
                           (foreign-function-backtrace-name
                            (int-sap (get-lisp-obj-address lra)))))
                         ((nil)
                          (make-bogus-debug-fun
                           "bogus stack frame"))
                         (t
                          (debug-fun-from-pc code pc-offset)))))
            (/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
            (make-compiled-frame caller up-frame d-fun
                                 (code-location-from-pc d-fun pc-offset
                                                        escaped)
                                 (if up-frame (1+ (frame-number up-frame)) 0)
                                 escaped))))))

#+(or x86 x86-64)
(defun compute-calling-frame (caller ra up-frame &optional savedp)
  (declare (type system-area-pointer caller ra))
  (/noshow0 "entering COMPUTE-CALLING-FRAME")
  (when (control-stack-pointer-valid-p caller)
    (/noshow0 "in WHEN")
    ;; First check for an escaped frame.
    (multiple-value-bind (code pc-offset escaped off-stack)
        (find-escaped-frame caller)
      (/noshow0 "at COND")
      (cond (code
             ;; If it's escaped it may be a function end breakpoint trap.
             (when (and (code-component-p code)
                        (eq (%code-debug-info code) :bpt-lra))
               ;; If :bpt-lra grab the real lra.
               (setq pc-offset (code-header-ref code (1+ real-lra-slot)))
               (setq code (code-header-ref code real-lra-slot))
               (aver code)))
            ((not escaped)
             (multiple-value-setq (pc-offset code)
               (compute-lra-data-from-pc ra))
             (unless code
               (setf code :foreign-function
                     pc-offset 0))))
      (let ((d-fun (case code
                     (:undefined-function
                      (make-bogus-debug-fun
                       "undefined function"))
                     (:foreign-function
                      (make-bogus-debug-fun
                       (foreign-function-backtrace-name ra)))
                     ((nil)
                      (make-bogus-debug-fun
                       "bogus stack frame"))
                     (t
                      (debug-fun-from-pc code pc-offset escaped)))))
        (/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
        (make-compiled-frame caller up-frame d-fun
                             (code-location-from-pc d-fun pc-offset
                                                    escaped)
                             (if up-frame (1+ (frame-number up-frame)) 0)
                             ;; If we have an interrupt-context that's not on
                             ;; our stack at all, and we're computing the
                             ;; from from a saved FP, we're probably looking
                             ;; at an interrupted syscall.
                             (or escaped (and savedp off-stack)))))))

(defun nth-interrupt-context (n)
  (declare (muffle-conditions compiler-note))
  (declare (type (mod #.sb-vm:max-interrupts) n)
           (optimize (speed 3) (safety 0)))
  (let ((tls-words (ash (sb-alien:extern-alien "dynamic_values_bytes"
                                               (sb-alien:unsigned 32))
                        (- sb-vm:word-shift))))
    (sb-alien:sap-alien (sb-vm::current-thread-offset-sap (+ tls-words n))
                        (* os-context-t))))

(defun catch-runaway-unwind (block)
  (declare (ignorable block))
  #-(and win32 x86) ;; uses SEH
  (let ((target (sap-ref-sap (descriptor-sap block)
                             (* unwind-block-uwp-slot n-word-bytes))))
    (loop for uwp = (descriptor-sap sb-vm::*current-unwind-protect-block*)
          then (sap-ref-sap uwp (* unwind-block-uwp-slot n-word-bytes))
          until (zerop (sap-int uwp))
          thereis (sap= target uwp)
          finally
          (let* ((pc (sap-ref-sap (descriptor-sap block)
                                  (* unwind-block-entry-pc-slot n-word-bytes)))
                 (code (code-header-from-pc pc))
                 (fun-name
                   (and code
                        (or
                         (multiple-value-bind (offset valid) (code-pc-offset pc code)
                           (and valid
                                (let ((debug-fun (debug-fun-from-pc code offset nil)))
                                  (and (compiled-debug-fun-p debug-fun)
                                       (debug-fun-name debug-fun)))))
                         code))))
            (error 'simple-control-error
                   :format-control
                   "Attempt to RETURN-FROM a block or GO to a tag that no longer exists~@[ in ~s~]"
                   :format-arguments (list fun-name))))))

(defun code-pc-offset (pc code)
  (declare (type code-component code))
  ;; We wrap WITH-PINNED-OBJECTS around CODE, but in truth this can go wrong if the
  ;; code was transported after taking a PC and before getting here. i.e. there is
  ;; nothing to be gained by arranging that while we calculate CODE-INSTRUCTIONS
  ;; the code can't move if it already moved.
  ;; The precisely GCed backends would be a lot more correct with respect to
  ;; debug-related stuff if we just never move code that is on-stack.
  (let ((pc-offset (with-pinned-objects (code)
                     (sap- pc (code-instructions code))))
        (code-size (%code-text-size code)))
    (values pc-offset (<= 0 pc-offset code-size) code-size)))

(defun context-code-pc-offset (context code)
  (code-pc-offset (context-pc context) code))

(defun find-escaped-frame (frame-pointer)
  (declare (type system-area-pointer frame-pointer))
  (/noshow0 "entering FIND-ESCAPED-FRAME")
  (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
    (let* ((context (nth-interrupt-context index))
           (cfp (int-sap (context-register context sb-vm::cfp-offset))))
      (/noshow0 "got CONTEXT")
      #+(or x86 x86-64)
      (unless (control-stack-pointer-valid-p cfp)
        (return (values nil nil nil t)))
      (when (sap= frame-pointer cfp)
        (with-code-pages-pinned (:dynamic)
          (return (escaped-frame-from-context context)))))))

#+(or x86 x86-64)
(defun escaped-frame-from-context (context)
  (declare (type (sb-alien:alien (* os-context-t)) context))
  (block nil
    (let ((code (code-object-from-context context)))
      (/noshow0 "got CODE")
      (when (null code)
        ;; KLUDGE: Detect undefined functions by a range-check
        ;; against the trampoline address and the following
        ;; function in the runtime.
        (return (values code 0 context)))
      (multiple-value-bind
            (pc-offset valid-p)
          (context-code-pc-offset context code)
        (unless valid-p
          ;; We were in an assembly routine. Therefore, use the
          ;; LRA as the pc.
          ;;
          ;; FIXME: Should this be WARN or ERROR or what?
          (format t "** pc-offset ~S not in code obj ~S?~%"
                  pc-offset code))
        (/noshow0 "returning from FIND-ESCAPED-FRAME")
        (return
          (values code pc-offset context))))))

#-(or x86 x86-64)
(defun escaped-frame-from-context (context)
  (declare (type (sb-alien:alien (* os-context-t)) context))
  (block nil
    (let ((code (code-object-from-context context)))
      (/noshow0 "got CODE")
      (when (symbolp code)
        (return (values code 0 context)))
      (multiple-value-bind
            (pc-offset valid-p code-size)
          (context-code-pc-offset context code)
        (unless valid-p
          ;; We were in an assembly routine.
          (multiple-value-bind (new-pc-offset computed-return)
              (find-pc-from-assembly-fun code context)
            (setf pc-offset new-pc-offset)
            (unless (<= 0 pc-offset code-size)
              (cerror
               "Set PC-OFFSET to zero and continue backtrace."
               'bug
               :format-control
               "~@<PC-OFFSET (~D) not in code object. Frame details:~
                   ~2I~:@_PC: #X~X~:@_CODE: ~S~:@_CODE FUN: ~S~:@_LRA: ~
                   #X~X~:@_COMPUTED RETURN: #X~X.~:>"
               :format-arguments
               (list pc-offset
                     (sap-int (context-pc context))
                     code
                     (%code-entry-point code 0)
                     #-(or arm arm64)
                     (context-register context sb-vm::lra-offset)
                     #+(or arm arm64)
                     (stack-ref (int-sap (context-register context
                                                           sb-vm::cfp-offset))
                                lra-save-offset)
                     computed-return))
              ;; We failed to pinpoint where PC is, but set
              ;; pc-offset to 0 to keep the backtrace from
              ;; exploding.
              (setf pc-offset 0))))
        (/noshow0 "returning from FIND-ESCAPED-FRAME")
        (return
          (if (eq (%code-debug-info code) :bpt-lra)
              (let ((real-lra (code-header-ref code real-lra-slot)))
                (values (lra-code-header real-lra)
                        (get-header-data real-lra)
                        nil))
              (values code pc-offset context)))))))

#-(or x86 x86-64)
(defun find-pc-from-assembly-fun (code scp)
  "Finds the PC for the return from an assembly routine properly.
For some architectures (such as PPC) this will not be the $LRA
register."
  (with-pinned-objects (code)
    (let ((return-machine-address (sb-vm::return-machine-address scp))
          (code-header-len (* (code-header-words code) sb-vm:n-word-bytes)))
      (values (- return-machine-address
                 (- (get-lisp-obj-address code)
                    sb-vm:other-pointer-lowtag)
                 code-header-len)
              return-machine-address))))

;;; Find the code object corresponding to the object represented by
;;; bits and return it. We assume bogus functions correspond to the
;;; undefined-function.
#+(or x86 x86-64)
(defun code-object-from-context (context)
  (declare (type (sb-alien:alien (* os-context-t)) context))
  (code-header-from-pc (context-pc context)))

#-(or x86 x86-64)
(defun code-object-from-context (context)
  (declare (type (sb-alien:alien (* os-context-t)) context))
  ;; The GC constraint on the program counter on precisely-scavenged
  ;; backends is that it partakes of the interior-pointer nature.
  ;; Which means that it may be within the scope of an object other
  ;; than that pointed to by reg_CODE / $CODE.  This is necessarily
  ;; the case during function call and return: whichever the outbound
  ;; function is has reg_CODE set up for itself, and the inbound
  ;; function cannot have reg_CODE set up until after the program
  ;; counter is within its body, otherwise a badly timed signal can
  ;; mess things up entirely.  In practical terms, this means that we
  ;; need to do the same sort of pairing of interior pointers that the
  ;; GC does these days (see scavenge_interrupt_context() in
  ;; gc-common.c for details), but limiting to "things that can be
  ;; code objects".  -- AB, 2018-Jan-11
  ;;
  ;; Oh, and as of this writing, AFAIK, the only precisely-scavenged
  ;; backends that are actually interrupt-safe around function calls
  ;; are PPC, ARM64, and probably ARM.  PPC and ARM64 because they
  ;; have thread support, and GC load testing on PPC is how this
  ;; constraint was found in the first place.  Probably ARM because I
  ;; wrote the bulk of the ARM backend well after I fixed function
  ;; calling on PPC and rewrote scavenge_interrupt_context() so that
  ;; things behaved reliably.  -- AB, 2018-Jan-11
  (flet ((normalize-candidate (object)
           ;; Unlike with the prior implementation, we cannot presume
           ;; that a FUNCTION is amenable to FUN-CODE-HEADER (it might
           ;; be a closure, and that is unlikely to be at all useful).
           ;; Fortunately, WIDETAG-OF comes up with sane values for
           ;; all object types, and we can pick off the SIMPLE-FUN
           ;; case easily enough.
           (let ((widetag (widetag-of object)))
             (cond ((= widetag code-header-widetag)
                    object)
                   ((= widetag return-pc-widetag)
                    (lra-code-header object))
                   ((= widetag simple-fun-widetag)
                    (or (fun-code-header object)
                        :undefined-function))
                   (t
                    nil)))))
    (dolist (boxed-reg-offset sb-vm::boxed-regs
                              ;; If we can't actually pair the PC then we presume that
                              ;; we're in an assembly-routine and that reg_CODE is, in
                              ;; fact, the right thing to use...  And that it will do
                              ;; no harm to return it here anyway even if it isn't.
                              (normalize-candidate
                               #+ppc64
                               (let ((code (context-register context sb-vm::code-offset)))
                                 (%make-lisp-obj (if (logtest sb-vm:lowtag-mask code)
                                                     code
                                                     (logior code sb-vm:other-pointer-lowtag))))
                               #-ppc64
                               (boxed-context-register context sb-vm::code-offset)))
      (let ((candidate
              (normalize-candidate
               (boxed-context-register context boxed-reg-offset))))
        (when (and (not (symbolp candidate)) ;; NIL or :UNDEFINED-FUNCTION
                   (nth-value 1 (context-code-pc-offset context candidate)))
          (return candidate))))))

;;;; frame utilities

(defun compiled-debug-fun-from-pc (debug-info pc &optional escaped)
  (let* ((fun-map (sb-c::compiled-debug-info-fun-map debug-info)))
    (if (sb-c::compiled-debug-fun-next fun-map)
        (let* ((first-elsewhere-pc (sb-c::compiled-debug-fun-elsewhere-pc fun-map))
               (elsewhere-p
                 (if escaped ;; See the comment below
                     (>= pc first-elsewhere-pc)
                     (> pc first-elsewhere-pc))))
          (loop for fun = fun-map then next
                for next = (sb-c::compiled-debug-fun-next fun)
                when (or (not next)
                         (let ((next-pc (if elsewhere-p
                                            (sb-c::compiled-debug-fun-elsewhere-pc next)
                                            (sb-c::compiled-debug-fun-offset next))))
                           (if escaped
                               (< pc next-pc)
                               ;; Non-escaped frame means that this frame calls something.
                               ;; And the PC points to where something should return.
                               ;; The return adress may be in the next
                               ;; function, e.g. in local tail calls the
                               ;; function will be entered just after the
                               ;; CALL.
                               ;; See debug.impure.lisp/:local-tail-call for a test-case
                               (<= pc next-pc))))
                return fun))
        fun-map)))

;;; This returns a COMPILED-DEBUG-FUN for COMPONENT and PC. We fetch the
;;; SB-C::DEBUG-INFO and run down its FUN-MAP to get a
;;; SB-C::COMPILED-DEBUG-FUN from the PC. The result only needs to
;;; reference the COMPONENT, for function constants, and the
;;; SB-C::COMPILED-DEBUG-FUN.
(defun debug-fun-from-pc (component pc &optional (escaped t))
  (let ((info (%code-debug-info component)))
    (etypecase info
      (sb-c::compiled-debug-info
       (make-compiled-debug-fun (compiled-debug-fun-from-pc info pc escaped) component))
      (hash-table ; interrupted in an assembler routine
       (let ((routine (dohash ((name pc-range) info)
                        (when (<= (car pc-range) pc (cadr pc-range))
                          (return name)))))
         (make-bogus-debug-fun (cond ((not routine)
                                      "no debug information for frame")
                                     ((memq routine '(sb-vm::undefined-tramp
                                                      sb-vm::undefined-alien-tramp))
                                      "undefined function")
                                     (routine)))))
      (closure ; interrupted in an immobile code trampoline
       (make-bogus-debug-fun "closure-calling trampoline"))
      ((eql :bpt-lra)
       (make-bogus-debug-fun "function end breakpoint")))))

;;; This returns a code-location for the COMPILED-DEBUG-FUN,
;;; DEBUG-FUN, and the pc into its code vector. If we stopped at a
;;; breakpoint, find the CODE-LOCATION for that breakpoint. Otherwise,
;;; make an :UNSURE code location, so it can be filled in when we
;;; figure out what is going on.
(defun code-location-from-pc (debug-fun pc escaped)
  (or (and (compiled-debug-fun-p debug-fun)
           escaped
           (let ((data (breakpoint-data
                        (compiled-debug-fun-component debug-fun)
                        pc nil)))
             (when (and data (breakpoint-data-breakpoints data))
               (let ((what (breakpoint-what
                            (first (breakpoint-data-breakpoints data)))))
                 (when (compiled-code-location-p what)
                   what)))))
      (make-compiled-code-location pc debug-fun)))

;;; Return an alist mapping catch tags to CODE-LOCATIONs. These are
;;; CODE-LOCATIONs at which execution would continue with frame as the
;;; top frame if someone threw to the corresponding tag.
(defun frame-catches (frame)
  (let ((catch (descriptor-sap *current-catch-block*))
        (reversed-result nil)
        (fp (frame-pointer frame)))
    (labels ((catch-ref (slot)
               (sap-ref-lispobj catch (* slot n-word-bytes)))
             #-(or x86 x86-64)
             (catch-entry-offset ()
               (let* ((lra (catch-ref catch-block-entry-pc-slot))
                      (component (catch-ref catch-block-code-slot))
                      #+ppc64
                      (component (%make-lisp-obj (logior (ash component n-fixnum-tag-bits)
                                                         other-pointer-lowtag))))
                 (* (- (1+ (get-header-data lra))
                       (code-header-words component))
                    n-word-bytes)))
             #+(or x86 x86-64)
             (catch-entry-offset ()
               (let* ((ra (sap-ref-sap
                           catch (* catch-block-entry-pc-slot
                                    n-word-bytes)))
                      (component (code-header-from-pc ra)))
                 (- (sap-int ra)
                    (- (get-lisp-obj-address component)
                       other-pointer-lowtag)
                    (* (code-header-words component)
                       n-word-bytes)))))
      (declare (inline catch-ref catch-entry-offset))
      (loop
         until (zerop (sap-int catch))
         finally (return (nreverse reversed-result))
         do (when (sap= fp
                        (descriptor-sap
                         (catch-ref catch-block-cfp-slot)))
              (push (cons (catch-ref catch-block-tag-slot)
                          (make-compiled-code-location
                           (catch-entry-offset) (frame-debug-fun frame)))
                    reversed-result))
           (setf catch
                 (descriptor-sap
                  (catch-ref catch-block-previous-catch-slot)))))))

;;; Modify the value of the OLD-TAG catches in FRAME to NEW-TAG
(defun replace-frame-catch-tag (frame old-tag new-tag)
  (let ((catch (descriptor-sap *current-catch-block*))
        (fp (frame-pointer frame)))
    (labels ((catch-ref (slot)
               (sap-ref-lispobj catch (* slot n-word-bytes)))
             ((setf catch-ref) (value slot)
               (setf (sap-ref-lispobj catch (* slot n-word-bytes))
                     value)))
      (declare (inline catch-ref (setf catch-ref)))
      (loop
         until (zerop (sap-int catch))
         do (when (sap= fp
                        (descriptor-sap
                         (catch-ref catch-block-cfp-slot)))
              (let ((current-tag (catch-ref catch-block-tag-slot)))
                (when (eq current-tag old-tag)
                  (setf (catch-ref catch-block-tag-slot) new-tag))))
         do (setf catch
                  (descriptor-sap
                   (catch-ref catch-block-previous-catch-slot)))))))



;;;; operations on DEBUG-FUNs

;;; Execute the forms in a context with BLOCK-VAR bound to each
;;; DEBUG-BLOCK in DEBUG-FUN successively. Result is an optional
;;; form to execute for return values, and DO-DEBUG-FUN-BLOCKS
;;; returns nil if there is no result form. This signals a
;;; NO-DEBUG-BLOCKS condition when the DEBUG-FUN lacks
;;; DEBUG-BLOCK information.
(defmacro do-debug-fun-blocks ((block-var debug-fun &optional result)
                               &body body)
  (let ((blocks (gensym))
        (i (gensym)))
    `(let ((,blocks (debug-fun-debug-blocks ,debug-fun)))
       (declare (simple-vector ,blocks))
       (dotimes (,i (length ,blocks) ,result)
         (let ((,block-var (svref ,blocks ,i)))
           ,@body)))))

;;; Execute body in a context with VAR bound to each DEBUG-VAR in
;;; DEBUG-FUN. This returns the value of executing result (defaults to
;;; nil). This may iterate over only some of DEBUG-FUN's variables or
;;; none depending on debug policy; for example, possibly the
;;; compilation only preserved argument information.
(defmacro do-debug-fun-vars ((var debug-fun &optional result) &body body)
  (let ((vars (gensym))
        (i (gensym)))
    `(let ((,vars (debug-fun-debug-vars ,debug-fun)))
       (if ,vars
           (dotimes (,i (compact-vector-length ,vars) ,result)
             (let ((,var (compact-vector-ref ,vars ,i)))
               ,@body))
           ,result))))

;;; Compute byte offset of FUNCTION into CODE-INSTRUCTIONS of its code,
;;; which is the byte offset from the base of its code
;;; minus the number of bytes in the boxed portion of its code header.
(defun function-start-pc-offset (function)
  (let* ((fun (%fun-fun function))
         (code (fun-code-header fun)))
    (- (%fun-code-offset fun)
       (* (code-header-words code) sb-vm:n-word-bytes))))

;;; Return the object of type FUNCTION associated with the DEBUG-FUN,
;;; or NIL if the function is unavailable or is non-existent as a user
;;; callable function object.
(defun debug-fun-fun (debug-fun)
  (let ((cached-value (debug-fun-%function debug-fun)))
    (if (eq cached-value :unparsed)
        (setf (debug-fun-%function debug-fun)
              (etypecase debug-fun
                (compiled-debug-fun
                 (let (result)
                   (loop with component = (compiled-debug-fun-component debug-fun)
                         with start-pc = (sb-c::compiled-debug-fun-start-pc
                                          (compiled-debug-fun-compiler-debug-fun debug-fun))
                         for i below (code-n-entries component)
                         for entry = (%code-entry-point component i)
                         while (> start-pc (function-start-pc-offset entry))
                         do (setf result entry))
                   result))
                (bogus-debug-fun nil)))
        cached-value)))

;;; Return the name of the function represented by DEBUG-FUN. This may
;;; be a string or a cons; do not assume it is a symbol.
(defun debug-fun-name (debug-fun &optional (pretty t))
  (declare (type debug-fun debug-fun) (ignorable pretty))
  (etypecase debug-fun
    (compiled-debug-fun
     (let ((name (sb-c::compiled-debug-fun-name
                  (compiled-debug-fun-compiler-debug-fun debug-fun))))
       ;; Frames named (.EVAL. special-operator) should show the operator name
       ;; in backtraces, but if the debugger needs to detect that the frame is
       ;; interpreted for other purposes, it can specify PRETTY = NIL.
       (cond #+sb-fasteval
             ((and (typep name '(cons (eql sb-interpreter::.eval.)))
                   pretty)
              (if (singleton-p (cdr name)) (cadr name) (cdr name)))
             (t name))))
    (bogus-debug-fun
     (bogus-debug-fun-%name debug-fun))))

(defun interrupted-frame-error (frame)
  (declare (special sb-kernel::*current-internal-error*))
  (when (and (compiled-frame-p frame)
             (compiled-frame-escaped frame)
             sb-kernel::*current-internal-error*
             (array-in-bounds-p sb-c:+backend-internal-errors+
                                sb-kernel::*current-internal-error*))
    (cadr (svref sb-c:+backend-internal-errors+
                 sb-kernel::*current-internal-error*))))

(defun all-args-available-p (frame)
  (let ((error (interrupted-frame-error frame))
        (df (frame-debug-fun frame)))
    (or (and (eq error 'invalid-arg-count-error)
             (eq (debug-fun-kind df) :external))
        (and (eq error 'undefined-fun-error)
             (bogus-debug-fun-p df)))))

;; Return the name of the closure, if named, otherwise nil.
(defun debug-fun-closure-name (debug-fun frame)
  (unless (typep debug-fun 'compiled-debug-fun)
    (return-from debug-fun-closure-name nil))
  (let ((compiler-debug-fun (compiled-debug-fun-compiler-debug-fun debug-fun)))
    (acond
       ;; Frames named (.APPLY. something) are interpreted function applicators.
       ;; Show them as the name of the interpreted function being applied.
       #+sb-fasteval
       ((let ((name (sb-c::compiled-debug-fun-name compiler-debug-fun)))
          (when (typep name '(cons (eql sb-interpreter::.apply.)))
            ;; Find a variable named FUN.
            (awhen (car (debug-fun-symbol-vars debug-fun 'sb-interpreter::fun))
              (let ((val (debug-var-value it frame))) ; Ensure it's a function
                (when (typep val 'interpreted-function)
                  (%fun-name val))))))) ; Get its name
       ((sb-c::compiled-debug-fun-closure-save compiler-debug-fun)
        (%fun-name
         (if (all-args-available-p frame)
             (sub-access-debug-var-slot (frame-pointer frame)
                                        sb-c:closure-sc
                                        (compiled-frame-escaped frame))
             (sub-access-debug-var-slot (frame-pointer frame) it)))))))

;;; Return a DEBUG-FUN that represents debug information for FUN.
(defun fun-debug-fun (fun)
  (declare (type function fun))
  (let ((simple-fun (%fun-fun fun)))
    (let* ((name (%simple-fun-name simple-fun))
           (component (fun-code-header simple-fun))
           (res (loop for fmap-entry = (sb-c::compiled-debug-info-fun-map
                                        (%code-debug-info component))
                      then next
                      for next = (sb-c::compiled-debug-fun-next fmap-entry)
                      ;; Is NAME really the right thing to match on given how bogus
                      ;; it might be? I would think PC range is better.
                      when (and (eq (sb-c::compiled-debug-fun-name fmap-entry) name)
                                (eq (sb-c::compiled-debug-fun-kind fmap-entry) nil))
                      return fmap-entry
                      while next)))
      (if res
          (make-compiled-debug-fun res component)
          ;; KLUDGE: comment from CMU CL:
          ;;   This used to be the non-interpreted branch, but
          ;;   William wrote it to return the debug-fun of fun's XEP
          ;;   instead of fun's debug-fun. The above code does this
          ;;   more correctly, but it doesn't get or eliminate all
          ;;   appropriate cases. It mostly works, and probably
          ;;   works for all named functions anyway.
          ;; -- WHN 20000120
          (debug-fun-from-pc component
                             (function-start-pc-offset simple-fun))))))

;;; Return the kind of the function, which is one of :OPTIONAL, :MORE
;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
(defun debug-fun-kind (debug-fun)
  ;; FIXME: This "is one of" information should become part of the function
  ;; declamation, not just a doc string
  (etypecase debug-fun
    (compiled-debug-fun
     (sb-c::compiled-debug-fun-kind
      (compiled-debug-fun-compiler-debug-fun debug-fun)))
    (bogus-debug-fun
     nil)))

;;; Is there any variable information for DEBUG-FUN?
(defun debug-var-info-available (debug-fun)
  (not (not (debug-fun-debug-vars debug-fun))))

;;; Return a list of DEBUG-VARs in DEBUG-FUN having the same name
;;; and package as SYMBOL. If SYMBOL is uninterned, then this returns
;;; a list of DEBUG-VARs without package names and with the same name
;;; as symbol. The result of this function is limited to the
;;; availability of variable information in DEBUG-FUN; for
;;; example, possibly DEBUG-FUN only knows about its arguments.
(defun debug-fun-symbol-vars (debug-fun symbol)
  (let ((vars (ambiguous-debug-vars debug-fun (symbol-name symbol)))
        (package (and (sb-xc:symbol-package symbol)
                      (package-name (sb-xc:symbol-package symbol)))))
    (delete-if (if (stringp package)
                   (lambda (var)
                     (let ((p (debug-var-package-name var)))
                       (or (not (stringp p))
                           (string/= p package))))
                   (lambda (var)
                     (stringp (debug-var-package-name var))))
               vars)))

;;; Return a list of DEBUG-VARs in DEBUG-FUN whose names contain
;;; NAME-PREFIX-STRING as an initial substring. The result of this
;;; function is limited to the availability of variable information in
;;; debug-fun; for example, possibly debug-fun only knows
;;; about its arguments.
(defun ambiguous-debug-vars (debug-fun name-prefix-string)
  (declare (simple-string name-prefix-string))
  (let* ((variables (debug-fun-debug-vars debug-fun))
         (len (compact-vector-length variables))
         (prefix-len (length name-prefix-string))
         (pos (find-var name-prefix-string variables len))
         (res nil))
    (when pos
      ;; Find names from pos to variable's len that contain prefix.
      (do ((i pos (1+ i)))
          ((= i len))
        (let* ((var (compact-vector-ref variables i))
               (name (debug-var-symbol-name var))
               (name-len (length name)))
          (declare (simple-string name))
          (when (/= (or (string/= name-prefix-string name
                                  :end1 prefix-len :end2 name-len)
                        prefix-len)
                    prefix-len)
            (return))
          (push var res)))
      (nreverse res))))

;;; This returns a position in VARIABLES for one containing NAME as an
;;; initial substring. END is the length of VARIABLES if supplied.
(defun find-var (name variables &optional end)
  (declare (simple-vector variables)
           (simple-string name))
  (let ((name-len (length name)))
    (position name variables
              :test (lambda (x y)
                      (let* ((y (debug-var-symbol-name y))
                             (y-len (length y)))
                        (declare (simple-string y))
                        (and (>= y-len name-len)
                             (string= x y :end1 name-len :end2 name-len))))
              :end (or end (length variables)))))

;;; Return a list representing the lambda-list for DEBUG-FUN. The
;;; list has the following structure:
;;;   (required-var1 required-var2
;;;    ...
;;;    (:optional var3 suppliedp-var4)
;;;    (:optional var5)
;;;    ...
;;;    (:rest var6) (:rest var7)
;;;    ...
;;;    (:keyword keyword-symbol var8 suppliedp-var9)
;;;    (:keyword keyword-symbol var10)
;;;    ...
;;;   )
;;; Each VARi is a DEBUG-VAR; however it may be the symbol :DELETED if
;;; it is unreferenced in DEBUG-FUN. This signals a
;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list
;;; information.
(defun debug-fun-lambda-list (debug-fun)
  (etypecase debug-fun
    (compiled-debug-fun (compiled-debug-fun-lambda-list debug-fun))
    (bogus-debug-fun nil)))

;;; Note: If this has to compute the lambda list, it caches it in DEBUG-FUN.
(defun compiled-debug-fun-lambda-list (debug-fun)
  (let ((lambda-list (debug-fun-%lambda-list debug-fun)))
    (cond ((eq lambda-list :unparsed)
           (multiple-value-bind (args argsp)
               (parse-compiled-debug-fun-lambda-list debug-fun)
             (setf (debug-fun-%lambda-list debug-fun) args)
             (if argsp
                 args
                 (debug-signal 'lambda-list-unavailable
                               :debug-fun debug-fun))))
          (lambda-list)
          ((bogus-debug-fun-p debug-fun)
           nil)
          ((sb-c::compiled-debug-fun-arguments
            (compiled-debug-fun-compiler-debug-fun debug-fun))
           ;; If the packed information is there (whether empty or not) as
           ;; opposed to being nil, then returned our cached value (nil).
           nil)
          (t
           ;; Our cached value is nil, and the packed lambda-list information
           ;; is nil, so we don't have anything available.
           (debug-signal 'lambda-list-unavailable
                         :debug-fun debug-fun)))))

;;; COMPILED-DEBUG-FUN-LAMBDA-LIST calls this when a
;;; COMPILED-DEBUG-FUN has no lambda list information cached. It
;;; returns the lambda list as the first value and whether there was
;;; any argument information as the second value. Therefore,
;;; (VALUES NIL T) means there were no arguments, but (VALUES NIL NIL)
;;; means there was no argument information.
(defun parse-compiled-debug-fun-lambda-list (debug-fun)
  ;; workaround type inference bogosity that made this file not recompilable.
  ;; debug-fun-debug-vars was getting derived as returning :unparsed which is not
  ;; a sequence which causes compilation of COERCE to warn.
  (declare (notinline debug-fun-debug-vars))
  (let ((args (sb-c::compiled-debug-fun-arguments
               (compiled-debug-fun-compiler-debug-fun debug-fun))))
    (cond
      ((not args)
       (values nil nil))
      ((eq args :minimal)
       (values (coerce (debug-fun-debug-vars debug-fun) 'list)
               t))
      (t
       (values (parse-compiled-debug-fun-lambda-list/args-available
                (debug-fun-debug-vars debug-fun) args)
               t)))))

;;; A compact "vector" is either the element itself or a vector
(defun compact-vector-ref (vector index)
  (declare (index index))
  (typecase vector
    (simple-vector
     (svref vector index))
    (string
     (aver (zerop index))
     vector)
    (vector
     (aref vector index))
    (t
     (aver (zerop index))
     vector)))

(defun compact-vector-length (vector)
  (typecase vector
    (string
     1)
    (vector
     (length vector))
    (t
     1)))

(defun parse-compiled-debug-fun-lambda-list/args-available (vars args)
  (let ((i 0)
        (len (compact-vector-length args))
        (optionalp nil)
        (keyword nil)
        (result '()))
    (flet ((push-var (tag-and-info &optional var-count)
             (push (if var-count
                       (append tag-and-info
                               (loop :repeat var-count :collect
                                     (compiled-debug-fun-lambda-list-var
                                      args (incf i) vars)))
                       tag-and-info)
                   result))
           (var-or-deleted (index-or-deleted)
             (if (eq index-or-deleted sb-c::debug-info-var-deleted)
                 :deleted
                 (compact-vector-ref vars index-or-deleted))))
      (loop
         :while (< i len)
         :for ele = (compact-vector-ref args i) :do
         (cond
           ((eq ele sb-c::debug-info-var-optional)
            (setf optionalp t))
           ((eq ele sb-c::debug-info-var-rest)
            (push-var '(:rest) 1))
           ;; The next two args are the &MORE arg context and
           ;; count.
           ((eq ele sb-c::debug-info-var-more)
            (push-var '(:more) 2))
           ;; SUPPLIED-P var immediately following keyword or
           ;; optional. Stick the extra var in the result element
           ;; representing the keyword or optional, which is the
           ;; previous one.
           ((eq ele sb-c::debug-info-var-supplied-p)
            (push-var (pop result) 1))
           ;; The keyword of a keyword parameter. Store it so the next
           ;; element can be used to form a (:keyword KEYWORD VALUE)
           ;; entry.
           ((typep ele 'symbol)
            (setf keyword ele))
           ;; The previous element was the keyword of a keyword
           ;; parameter and is stored in KEYWORD. The current element
           ;; is the index of the value (or a deleted
           ;; marker). Construct and push the complete entry.
           (keyword
            (push-var (list :keyword keyword (var-or-deleted ele))))
           ;; We saw an optional marker, so the following non-symbols
           ;; are indexes (or deleted markers) indicating optional
           ;; variables.
           (optionalp
            (push-var (list :optional (var-or-deleted ele))))
           ;; Deleted required, optional or keyword argument.
           ((eq ele sb-c::debug-info-var-deleted)
            (push-var :deleted))
           ;; Required arg at beginning of args array.
           (t
            (push-var (compact-vector-ref vars ele))))
         (incf i)
         :finally (return (nreverse result))))))

;;; This is used in COMPILED-DEBUG-FUN-LAMBDA-LIST.
(defun compiled-debug-fun-lambda-list-var (args i vars)
  (let ((ele (compact-vector-ref args i)))
    (cond ((typep ele 'index) (compact-vector-ref vars ele))
          ((eq ele sb-c::debug-info-var-deleted) :deleted)
          (t (error "malformed arguments description")))))

(defun compiled-debug-fun-debug-info (debug-fun)
  (%code-debug-info (compiled-debug-fun-component debug-fun)))

;;;; unpacking variable and basic block data

;;; The argument is a debug internals structure. This returns the
;;; DEBUG-BLOCKs for DEBUG-FUN, regardless of whether we have unpacked
;;; them yet. It signals a NO-DEBUG-BLOCKS condition if it can't
;;; return the blocks.
(defun debug-fun-debug-blocks (debug-fun)
  (let ((blocks (debug-fun-blocks debug-fun)))
    (when (eq blocks :unparsed)
      (let* ((new (parse-debug-blocks debug-fun))
             (old (cas (debug-fun-blocks debug-fun) :unparsed new)))
        (setq blocks (if (eq old :unparsed) new old))))
    (or blocks
        (debug-signal 'no-debug-blocks :debug-fun debug-fun))))

;;; Return a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates there
;;; was no basic block information.
(defun parse-debug-blocks (debug-fun)
  (etypecase debug-fun
    (compiled-debug-fun
     (let ((parsed (parse-compiled-debug-blocks debug-fun)))
       (if (equalp parsed #())
           (debug-signal 'no-debug-blocks :debug-fun debug-fun)
           parsed)))
    (bogus-debug-fun
     (debug-signal 'no-debug-blocks :debug-fun debug-fun))))

;;; This does some of the work of PARSE-DEBUG-BLOCKS.
(defun parse-compiled-debug-blocks (debug-fun)
  (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
    (let* ((var-count (length (debug-fun-debug-vars debug-fun)))
           (compiler-debug-fun (compiled-debug-fun-compiler-debug-fun
                                debug-fun))
           (compressed-data
            (or (sb-c::compiled-debug-fun-blocks compiler-debug-fun)
                (return-from parse-compiled-debug-blocks nil)))
           (blocks (sb-c::lz-decompress compressed-data))
           ;; KLUDGE: 8 is a hard-wired constant in the compiler for the
           ;; element size of the packed binary representation of the
           ;; blocks data.
           (live-set-len (ceiling var-count 8))
           (elsewhere-pc (sb-c::compiled-debug-fun-elsewhere-pc compiler-debug-fun))
           elsewhere-p
           (len (length blocks))
           (i 0)
           (last-pc 0)
           result-blocks
           (block (make-compiled-debug-block))
           locations
           prev-live
           prev-form-number)
      (flet ((new-block ()
               (when locations
                 (setf (compiled-debug-block-code-locations block)
                       (coerce (nreverse (shiftf locations nil))
                               'simple-vector)
                       (compiled-debug-block-elsewhere-p block)
                       elsewhere-p)
                 (push block result-blocks)
                 (setf block (make-compiled-debug-block)))))
        (loop
         (when (>= i len)
           (new-block)
           (return))
         (let* ((flags (aref+ blocks i))
                (kind (svref sb-c::+compiled-code-location-kinds+
                             (ldb (byte 3 0) flags)))
                (pc (+ last-pc
                       (sb-c:read-var-integerf blocks i)))
                (equal-live (logtest sb-c::compiled-code-location-equal-live flags))
                (form-number
                  (cond ((logtest sb-c::compiled-code-location-zero-form-number flags)
                         0)
                        ((and equal-live
                              (logtest sb-c::compiled-code-location-live flags))
                         prev-form-number)
                        (t
                         (setf prev-form-number
                               (sb-c:read-var-integerf blocks i)))))
                (live-set
                  (cond (equal-live
                         prev-live)
                        ((logtest sb-c::compiled-code-location-live flags)
                         (setf prev-live
                               (sb-c:read-packed-bit-vector live-set-len blocks i)))
                        (t
                         (make-array (* live-set-len 8) :element-type 'bit))))
                (step-info
                  (if (logtest sb-c::compiled-code-location-stepping flags)
                      (sb-c:read-var-string blocks i)
                      ""))
                (context
                  (and (logtest sb-c::compiled-code-location-context flags)
                       (compact-vector-ref (sb-c::compiled-debug-info-contexts
                                            (%code-debug-info (compiled-debug-fun-component debug-fun)))
                                           (sb-c:read-var-integerf blocks i)))))
           (when (or (memq kind '(:block-start :non-local-entry))
                     (and (not elsewhere-p)
                          (> pc elsewhere-pc)
                          (setf elsewhere-p t)))
             (new-block))
           (push (make-known-code-location
                  pc debug-fun block
                  form-number live-set kind
                  step-info context)
                 locations)
           (setf last-pc pc))))
      (coerce (nreverse result-blocks) 'simple-vector))))

;;; The argument is a debug internals structure. This returns NIL if
;;; there is no variable information. It returns an empty
;;; simple-vector if there were no locals in the function. Otherwise
;;; it returns a SIMPLE-VECTOR of DEBUG-VARs.
(defun debug-fun-debug-vars (debug-fun)
  (let ((vars (debug-fun-%debug-vars debug-fun)))
    (if (eq vars :unparsed)
        (let* ((new (etypecase debug-fun
                      (compiled-debug-fun
                       (parse-compiled-debug-vars debug-fun))
                      (bogus-debug-fun nil)))
               (old (cas (debug-fun-%debug-vars debug-fun) :unparsed new)))
          (if (eq old :unparsed) new old))
        vars)))

;;; VARS is the parsed variables for a minimal debug function. We need
;;; to assign names of the form ARG-NNN. We must pad with leading
;;; zeros, since the arguments must be in alphabetical order.
(defun assign-minimal-var-names (vars)
  (declare (simple-vector vars))
  (let* ((len (length vars))
         (width (length (format nil "~W" (1- len)))))
    (dotimes (i len)
      (without-package-locks
        (setf (compiled-debug-var-symbol (svref vars i))
              (intern (format nil "ARG-~V,'0D" width i)
                      #.(find-package "SB-DEBUG")))))))

;;; Parse the packed representation of DEBUG-VARs from
;;; DEBUG-FUN's SB-C::COMPILED-DEBUG-FUN, returning a vector
;;; of DEBUG-VARs, or NIL if there was no information to parse.
(defun parse-compiled-debug-vars (debug-fun)
  (let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun
                      debug-fun))
         (packed-vars (sb-c::compiled-debug-fun-vars cdebug-fun))
         (length (if (vectorp packed-vars)
                     (length packed-vars)
                     1))
         (args-minimal (eq (sb-c::compiled-debug-fun-arguments cdebug-fun)
                           :minimal)))
    (when packed-vars
      (do ((i 0)
           (id 0)
           prev-name
           (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
          ((>= i length)
           (let ((result (coerce buffer 'simple-vector)))
             (when args-minimal
               (assign-minimal-var-names result))
             result))
        (flet ((geti () (prog1 (compact-vector-ref packed-vars i) (incf i))))
          (let* ((flags (geti))
                 (minimal (logtest sb-c::compiled-debug-var-minimal-p flags))
                 (deleted (logtest sb-c::compiled-debug-var-deleted-p flags))
                 (more-context-p (logtest sb-c::compiled-debug-var-more-context-p flags))
                 (more-count-p (logtest sb-c::compiled-debug-var-more-count-p flags))
                 (indirect-p (logtest sb-c::compiled-debug-var-indirect-p flags))
                 (live (logtest sb-c::compiled-debug-var-environment-live
                                flags))
                 (save (logtest sb-c::compiled-debug-var-save-loc-p flags))
                 (symbol (cond ((or more-count-p
                                    more-context-p
                                    minimal)
                                nil)
                               ((logtest sb-c::compiled-debug-var-same-name-p flags)
                                prev-name)
                               (t (geti))))
                 ;; Keep the condition in sync with DUMP-1-VAR
                 (large-fixnums (>= (integer-length most-positive-fixnum) 62))
                 (sc+offset (if deleted 0
                                (if large-fixnums (ldb (byte 27 8) flags) (geti))))
                 (save-sc+offset (and save
                                      (if large-fixnums (ldb (byte 27 35) flags) (geti))))
                 (indirect-sc+offset (and indirect-p
                                          (geti))))
            (aver (not (and args-minimal (not minimal))))
            (cond ((and prev-name (string= prev-name symbol))
                   (incf id))
                  (t
                   (setf id 0
                         prev-name symbol)))
            (vector-push-extend (make-compiled-debug-var
                                 (if (stringp symbol) (make-symbol symbol) symbol)
                                 id
                                 live
                                 sc+offset
                                 save-sc+offset
                                 indirect-sc+offset
                                 (cond (more-context-p :more-context)
                                       (more-count-p :more-count)))
                                buffer)))))))

;;;; CODE-LOCATIONs

;;; If we're sure of whether code-location is known, return T or NIL.
;;; If we're :UNSURE, then try to fill in the code-location's slots.
;;; This determines whether there is any debug-block information, and
;;; if code-location is known.
;;;
;;; ??? IF this conses closures every time it's called, then break off the
;;; :UNSURE part to get the HANDLER-CASE into another function.
(defun code-location-unknown-p (basic-code-location)
  (ecase (code-location-%unknown-p basic-code-location)
    ((t) t)
    ((nil) nil)
    (:unsure
     (setf (code-location-%unknown-p basic-code-location)
           (handler-case (not (fill-in-code-location basic-code-location))
             (no-debug-blocks () t))))))

;;; Return the DEBUG-BLOCK containing code-location if it is available.
;;; Some debug policies inhibit debug-block information, and if none
;;; is available, then this signals a NO-DEBUG-BLOCKS condition.
(defun code-location-debug-block (basic-code-location)
  (let ((block (code-location-%debug-block basic-code-location)))
    (if (eq block :unparsed)
        (etypecase basic-code-location
          (compiled-code-location
           (compute-compiled-code-location-debug-block basic-code-location))
          ;; (There used to be more cases back before sbcl-0.7.0, when
          ;; we did special tricks to debug the IR1 interpreter.)
          )
        block)))

;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines
;;; the correct one using the code-location's pc. We use
;;; DEBUG-FUN-DEBUG-BLOCKS to return the cached block information
;;; or signal a NO-DEBUG-BLOCKS condition. The blocks are sorted by
;;; their first code-location's pc, in ascending order. Therefore, as
;;; soon as we find a block that starts with a pc greater than
;;; basic-code-location's pc, we know the previous block contains the
;;; pc. If we get to the last block, then the code-location is either
;;; in the second to last block or the last block, and we have to be
;;; careful in determining this since the last block could be code at
;;; the end of the function. We have to check for the last block being
;;; code first in order to see how to compare the code-location's pc.
(defun compute-compiled-code-location-debug-block (basic-code-location)
  (let* ((pc (compiled-code-location-pc basic-code-location))
         (debug-fun (code-location-debug-fun
                          basic-code-location))
         (blocks (debug-fun-debug-blocks debug-fun))
         (len (length blocks)))
    (declare (simple-vector blocks))
    (setf (code-location-%debug-block basic-code-location)
          (if (= len 1)
              (svref blocks 0)
              (do ((i 1 (1+ i))
                   (end (1- len)))
                  ((= i end)
                   (let ((last (svref blocks end)))
                     (cond
                      ((debug-block-elsewhere-p last)
                       (if (< pc
                              (sb-c::compiled-debug-fun-elsewhere-pc
                               (compiled-debug-fun-compiler-debug-fun
                                debug-fun)))
                           (svref blocks (1- end))
                           last))
                      ((< pc
                          (compiled-code-location-pc
                           (svref (compiled-debug-block-code-locations last)
                                  0)))
                       (svref blocks (1- end)))
                      (t last))))
                (declare (type index i end))
                (when (< pc
                         (compiled-code-location-pc
                          (svref (compiled-debug-block-code-locations
                                  (svref blocks i))
                                 0)))
                  (return (svref blocks (1- i)))))))))

;;; Return the CODE-LOCATION's DEBUG-SOURCE.
(defun code-location-debug-source (code-location)
  (let ((info (compiled-debug-fun-debug-info
               (code-location-debug-fun code-location))))
    (or (sb-c::debug-info-source info)
        (debug-signal 'no-debug-blocks :debug-fun
                      (code-location-debug-fun code-location)))))

;;; Returns the number of top level forms before the one containing
;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A
;;; compilation unit is not necessarily a single file, see the section
;;; on debug-sources.)
(defun code-location-toplevel-form-offset (code-location)
  (let ((di (compiled-debug-fun-debug-info
             (code-location-debug-fun code-location))))
    (sb-c::compiled-debug-info-tlf-number di)))

;;; Return the number of the form corresponding to CODE-LOCATION. The
;;; form number is derived by a walking the subforms of a top level
;;; form in depth-first order.
(defun code-location-form-number (code-location)
  (when (code-location-unknown-p code-location)
    (error 'unknown-code-location :code-location code-location))
  (let ((form-num (code-location-%form-number code-location)))
    (cond ((eq form-num :unparsed)
           (etypecase code-location
             (compiled-code-location
              (unless (fill-in-code-location code-location)
                ;; This check should be unnecessary. We're missing
                ;; debug info the compiler should have dumped.
                (bug "unknown code location"))
              (code-location-%form-number code-location))
             ;; (There used to be more cases back before sbcl-0.7.0,,
             ;; when we did special tricks to debug the IR1
             ;; interpreter.)
             ))
          (t form-num))))

;;; Return the kind of CODE-LOCATION, one of:
;;;  :INTERPRETED, :UNKNOWN-RETURN, :KNOWN-RETURN, :INTERNAL-ERROR,
;;;  :NON-LOCAL-EXIT, :BLOCK-START, :CALL-SITE, :SINGLE-VALUE-RETURN,
;;;  :NON-LOCAL-ENTRY
(defun code-location-kind (code-location)
  (when (code-location-unknown-p code-location)
    (error 'unknown-code-location :code-location code-location))
  (etypecase code-location
    (compiled-code-location
     (let ((kind (compiled-code-location-kind code-location)))
       (cond ((not (eq kind :unparsed)) kind)
             ((not (fill-in-code-location code-location))
              ;; This check should be unnecessary. We're missing
              ;; debug info the compiler should have dumped.
              (bug "unknown code location"))
             (t
              (compiled-code-location-kind code-location)))))
    ;; (There used to be more cases back before sbcl-0.7.0,,
    ;; when we did special tricks to debug the IR1
    ;; interpreter.)
    ))

;;; This returns CODE-LOCATION's live-set if it is available. If
;;; there is no debug-block information, this returns NIL.
(defun compiled-code-location-live-set (code-location)
  (if (code-location-unknown-p code-location)
      nil
      (let ((live-set (compiled-code-location-%live-set code-location)))
        (fill-in-code-location code-location)
        (cond ((eq live-set :unparsed)
               (unless (fill-in-code-location code-location)
                 ;; This check should be unnecessary. We're missing
                 ;; debug info the compiler should have dumped.
                 ;;
                 ;; FIXME: This error and comment happen over and over again.
                 ;; Make them a shared function.
                 (bug "unknown code location"))
               (compiled-code-location-%live-set code-location))
              (t live-set)))))

(defun code-location-context (code-location)
  (unless (code-location-unknown-p code-location)
    (let ((context (compiled-code-location-context code-location)))
      (cond ((eq context :unparsed)
             (etypecase code-location
               (compiled-code-location
                (unless (fill-in-code-location code-location)
                  (bug "unknown code location"))
                (compiled-code-location-context code-location))))
            (t context)))))

(defun error-context (&optional (frame sb-debug:*stack-top-hint*))
  (when frame
    (code-location-context (frame-code-location frame))))

(defun decode-arithmetic-error-operands (context)
  (let* ((alien-context (sb-alien:sap-alien context (* os-context-t)))
         (fp (int-sap (context-register alien-context
                                        sb-vm::cfp-offset)))
         (sb-debug:*stack-top-hint* (find-interrupted-frame))
         (error-context (error-context)))
    (and error-context
         (values (car error-context)
                 (loop for x in (cdr error-context)
                       collect (if (integerp x)
                                   (sub-access-debug-var-slot
                                    fp x alien-context)
                                   x))))))

;;; true if OBJ1 and OBJ2 are the same place in the code
(defun code-location= (obj1 obj2)
  (etypecase obj1
    (compiled-code-location
     (etypecase obj2
       (compiled-code-location
        (and (eq (code-location-debug-fun obj1)
                 (code-location-debug-fun obj2))
             (sub-compiled-code-location= obj1 obj2)))
       ;; (There used to be more cases back before sbcl-0.7.0,,
       ;; when we did special tricks to debug the IR1
       ;; interpreter.)
       ))
    ;; (There used to be more cases back before sbcl-0.7.0,,
    ;; when we did special tricks to debug IR1-interpreted code.)
    ))
(defun sub-compiled-code-location= (obj1 obj2)
  (= (compiled-code-location-pc obj1)
     (compiled-code-location-pc obj2)))

;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL
;;; depending on whether the code-location was known in its
;;; DEBUG-FUN's debug-block information. This may signal a
;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUN-DEBUG-BLOCKS, and
;;; it assumes the %UNKNOWN-P slot is already set or going to be set.
(defun fill-in-code-location (code-location)
  (declare (type compiled-code-location code-location))
  (let* ((debug-fun (code-location-debug-fun code-location))
         (blocks (debug-fun-debug-blocks debug-fun))
         (found))
    (declare (simple-vector blocks))
    (dotimes (i (length blocks) nil)
      (let* ((block (svref blocks i))
             (locations (compiled-debug-block-code-locations block)))
        (declare (simple-vector locations))
        (dotimes (j (length locations))
          (let ((loc (svref locations j)))
            (when (sub-compiled-code-location= code-location loc)
              (unless found
                (setf found loc))
              ;; There may be multiple locations in multiple blocks at a given PC, prefer
              ;; the :internal-error ones.
              (when (eq (compiled-code-location-kind loc) :internal-error)
                (setf found loc)
                (return)))))))
    (when found
      (setf (code-location-%debug-block code-location)
            (code-location-%debug-block found))
      (setf (code-location-%form-number code-location)
            (code-location-%form-number found))
      (setf (compiled-code-location-%live-set code-location)
            (compiled-code-location-%live-set found))
      (setf (compiled-code-location-kind code-location)
            (compiled-code-location-kind found))
      (setf (compiled-code-location-step-info code-location)
            (compiled-code-location-step-info found))
      (setf (compiled-code-location-context code-location)
            (compiled-code-location-context found))
      t)))

;;;; operations on DEBUG-BLOCKs

;;; Execute FORMS in a context with CODE-VAR bound to each
;;; CODE-LOCATION in DEBUG-BLOCK, and return the value of RESULT.
(defmacro do-debug-block-locations ((code-var debug-block &optional result)
                                    &body body)
  (let ((code-locations (gensym))
        (i (gensym)))
    `(let ((,code-locations (debug-block-code-locations ,debug-block)))
       (declare (simple-vector ,code-locations))
       (dotimes (,i (length ,code-locations) ,result)
         (let ((,code-var (svref ,code-locations ,i)))
           ,@body)))))

;;; Return the name of the function represented by DEBUG-FUN.
;;; This may be a string or a cons; do not assume it is a symbol.
(defun debug-block-fun-name (debug-block)
  (etypecase debug-block
    (compiled-debug-block
     (let ((code-locs (compiled-debug-block-code-locations debug-block)))
       (declare (simple-vector code-locs))
       (if (zerop (length code-locs))
           "??? Can't get name of debug-block's function."
           (debug-fun-name
            (code-location-debug-fun (svref code-locs 0))))))
    ;; (There used to be more cases back before sbcl-0.7.0, when we
    ;; did special tricks to debug the IR1 interpreter.)
    ))

(defun debug-block-code-locations (debug-block)
  (etypecase debug-block
    (compiled-debug-block
     (compiled-debug-block-code-locations debug-block))
    ;; (There used to be more cases back before sbcl-0.7.0, when we
    ;; did special tricks to debug the IR1 interpreter.)
    ))

;;;; operations on debug variables

(defun debug-var-symbol-name (debug-var)
  (symbol-name (debug-var-symbol debug-var)))

;;; FIXME: Make sure that this isn't called anywhere that it wouldn't
;;; be acceptable to have NIL returned, or that it's only called on
;;; DEBUG-VARs whose symbols have non-NIL packages.
(defun debug-var-package-name (debug-var)
  (package-name (sb-xc:symbol-package (debug-var-symbol debug-var))))

;;; Return the value stored for DEBUG-VAR in frame, or if the value is
;;; not :VALID, then signal an INVALID-VALUE error.
(defun debug-var-valid-value (debug-var frame)
  (unless (eq (debug-var-validity debug-var (frame-code-location frame))
              :valid)
    (error 'invalid-value :debug-var debug-var :frame frame))
  (debug-var-value debug-var frame))

;;; Returns the value stored for DEBUG-VAR in frame. The value may be
;;; invalid. This is SETFable.
(defun debug-var-value (debug-var frame)
  (aver (typep frame 'compiled-frame))
  (let ((res (access-compiled-debug-var-slot debug-var frame)))
    (if (indirect-value-cell-p res)
        (value-cell-ref res)
        res)))

;;; This returns what is stored for the variable represented by
;;; DEBUG-VAR relative to the FRAME. This may be an indirect value
;;; cell if the variable is both closed over and set.
(defun access-compiled-debug-var-slot (debug-var frame)
  (let ((escaped (compiled-frame-escaped frame)))
    (cond ((compiled-debug-var-indirect-sc+offset debug-var)
           (sub-access-debug-var-slot
            ;; Indirect are accessed through a frame pointer of the parent.
            (descriptor-sap
             (sub-access-debug-var-slot
              (frame-pointer frame)
              (if escaped
                  (compiled-debug-var-sc+offset debug-var)
                  (or
                   (compiled-debug-var-save-sc+offset debug-var)
                   (compiled-debug-var-sc+offset debug-var)))
              escaped))
            (compiled-debug-var-indirect-sc+offset debug-var)
            escaped))
          (escaped
           (sub-access-debug-var-slot
            (frame-pointer frame)
            (compiled-debug-var-sc+offset debug-var)
            escaped))
          (t
           (sub-access-debug-var-slot
            (frame-pointer frame)
            (or (compiled-debug-var-save-sc+offset debug-var)
                (compiled-debug-var-sc+offset debug-var)))))))

;;; a helper function for working with possibly-invalid values:
;;; Do (%MAKE-LISP-OBJ VAL) only if the value looks valid.
;;;
;;; (Such values can arise in registers on machines with conservative
;;; GC, and might also arise in debug variable locations when
;;; those variables are invalid.)
;;;
;;; NOTE for precisely GC'd platforms:
;;; this function is not GC-safe in the slightest when creating
;;; a pointer to an object in dynamic space.  If a GC occurs between
;;; the start of the call to VALID-LISP-POINTER-P and the end of
;;; %MAKE-LISP-OBJ then the object could move before the boxed pointer
;;; is constructed.  This can happen on CHENEYGC if an asynchronous
;;; interrupt occurs within the window.  This can happen on GENCGC
;;; under the same circumstances, but is more likely due to all GENCGC
;;; platforms supporting threaded operation.

;;; On x86oids we are able to eliminate the vulnerable window
;;; by conservatively pinning an object (i.e. storing a bit pattern
;;; that would be the address of an object, assuming it is an object)
;;; whether or not there is actually an object to pin.
;;; To see the GC-safeness problem without WITH-PINNED-OBJECTS, consider
;;; the following sequence of events, and suppose for the sake of argument
;;; that tagged pointer #x104003 is valid at the moment of call.
;;; Assume 1 low zero bit in a fixnum, so the register contains #x208006.
;;; 1. move-to-word: arg-passing-reg <- #x104003 ; implicit pin
;;;    /* at this point the fixnum whose representation is #x208006
;;;       was spilled to stack prior to call, *and* the descriptor bits
;;;       are also in a register. The fixnum pins nothing as it does not
;;;       have Lisp pointer nature. The passing reg pins something */
;;; 2. call C : will return true, and assume that the arg-passing-reg
;;;             gets clobbered.  The return-reg contains 1 for true.
;;; 3. -- GC triggered by other thread
;;;       transport the object that was #x104003 to somewhere new
;;; 4. now %MAKE-LISP-OBJ creates a bogus pointer.
;;; By preemptively using (WITH-PINNED-OBJECTS ((%MAKE-LISP-OBJ)))
;;; we ensure that the bit pattern #x104003 is on the stack for root scan.
;;; Unfortunately, WITH-PINNED-OBJECTS can not be used with precise GC
;;; because random trash is not allowed in a descriptor register.
;;; If we really wanted to make this safe for precise GC, we could use a
;;; new special binding, something like *PINNED-WORDS* which would be a list
;;; of INTEGERs, each of which, _if_ its bit pattern is that of an object
;;; descriptor, would pin the corresponding object. On the lisp side
;;; the cons cell in the list would hold the supplied VAL directly.
(defun make-lisp-obj (val &optional (errorp t))
  (if (or
       ;; fixnum
       (zerop (logand val sb-vm:fixnum-tag-mask))
       ;; immediate single float, 64-bit only
       #+64-bit
       (= (logand val #xff) sb-vm:single-float-widetag)
       ;; character
       (and (zerop (logandc2 val #x1fffffff)) ; Top bits zero
            (= (logand val #xff) sb-vm:character-widetag)) ; char tag
       ;; unbound marker
       (= val sb-vm:unbound-marker-widetag))
      (values (%make-lisp-obj val) t)
      ;; To mitigate the danger of GC running in between testing pointer
      ;; validity and returning the object, we must pin a potentially
      ;; non-object which is harmless on the conservative backends
      ;; but harmful on precise GC.
      (macrolet ((possibly-pin (form)
                   #+(or x86 x86-64)
                   `(with-pinned-objects ((%make-lisp-obj val)) ,form)
                   #-(or x86 x86-64) form))
        (let ((obj (if (and (typep val 'word) (is-lisp-pointer val))
                       (possibly-pin
                        (if (= (valid-lisp-pointer-p (int-sap val)) 0)
                            0
                            (%make-lisp-obj val)))
                       0)))
          (cond ((not (eql obj 0)) (values obj t))
                (errorp
                 (error "~S is not a valid argument to ~S"
                        val 'make-lisp-obj))
                (t
                 (values (make-unprintable-object
                          (format nil "invalid object #x~X" val))
                         nil)))))))

(defun sub-access-debug-var-slot (fp sc+offset &optional escaped)
  ;; NOTE: The long-float support in here is obviously decayed.  When
  ;; the x86oid and non-x86oid versions of this function were unified,
  ;; the behavior of long-floats was preserved, which only served to
  ;; highlight its brokenness.
  (macrolet ((with-escaped-value ((var) &body forms)
               `(if escaped
                    (let ((,var (sb-vm:context-register
                                 escaped
                                 (sb-c:sc+offset-offset sc+offset))))
                      ,@forms)
                    :invalid-value-for-unescaped-register-storage))
             (escaped-boxed-value ()
               `(if escaped
                    (boxed-context-register
                     escaped
                     (sb-c:sc+offset-offset sc+offset))
                    :invalid-value-for-unescaped-register-storage))
             (escaped-float-value (format)
               `(if escaped
                    (sb-vm:context-float-register
                     escaped
                     (sb-c:sc+offset-offset sc+offset) ',format)
                    :invalid-value-for-unescaped-register-storage))
             (with-nfp ((var) &body body)
               ;; x86oids have no separate number stack, so dummy it
               ;; up for them.
               #+c-stack-is-control-stack
               `(let ((,var fp))
                  ,@body)
               #-c-stack-is-control-stack
               `(let ((,var (if escaped
                                (int-sap
                                 (sb-vm:context-register escaped
                                                         sb-vm::nfp-offset))
                                (sap-ref-sap fp (* nfp-save-offset
                                                   sb-vm:n-word-bytes)))))
                  ,@body))
             (number-stack-offset (&optional (offset 0))
               #+(or x86 x86-64)
               `(+ (sb-vm::frame-byte-offset (sb-c:sc+offset-offset sc+offset))
                   ,offset)
               #-(or x86 x86-64)
               `(+ (* (sb-c:sc+offset-offset sc+offset) sb-vm:n-word-bytes)
                   ,offset)))
    (ecase (sb-c:sc+offset-scn sc+offset)
      ((#.sb-vm:any-reg-sc-number
        #.sb-vm:descriptor-reg-sc-number)
       (escaped-boxed-value))
      (#.sb-vm:character-reg-sc-number
       (with-escaped-value (val)
         (code-char val)))
      (#.sb-vm:sap-reg-sc-number
       (with-escaped-value (val)
         (int-sap val)))
      (#.sb-vm:signed-reg-sc-number
       (with-escaped-value (val)
         (if (logbitp (1- sb-vm:n-word-bits) val)
             (logior val (ash -1 sb-vm:n-word-bits))
             val)))
      (#.sb-vm:unsigned-reg-sc-number
       (with-escaped-value (val)
         val))
      #-(or x86 x86-64)
      (#.sb-vm:non-descriptor-reg-sc-number
       (error "Local non-descriptor register access?"))
      #-(or x86 x86-64)
      (#.sb-vm:interior-reg-sc-number
       (error "Local interior register access?"))
      (#.sb-vm:single-reg-sc-number
       (escaped-float-value single-float))
      (#.sb-vm:double-reg-sc-number
       (escaped-float-value double-float))
      #+long-float
      (#.sb-vm:long-reg-sc-number
       (escaped-float-value long-float))
      (#.sb-vm:complex-single-reg-sc-number
       (escaped-float-value complex-single-float))
      (#.sb-vm:complex-double-reg-sc-number
       (escaped-float-value complex-double-float))
      #+long-float
      (#.sb-vm:complex-long-reg-sc-number
       (escaped-float-value sb-kernel::complex-long-float))
      (#.sb-vm:single-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-single nfp (number-stack-offset))))
      (#.sb-vm:double-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-double nfp (number-stack-offset))))
      #+long-float
      (#.sb-vm:long-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-long nfp (number-stack-offset))))
      (#.sb-vm:complex-single-stack-sc-number
       (with-nfp (nfp)
         (complex
          (sap-ref-single nfp (number-stack-offset))
          (sap-ref-single nfp (number-stack-offset 4)))))
      (#.sb-vm:complex-double-stack-sc-number
       (with-nfp (nfp)
         (complex
          (sap-ref-double nfp (number-stack-offset))
          (sap-ref-double nfp (number-stack-offset 8)))))
      #+long-float
      (#.sb-vm:complex-long-stack-sc-number
       (with-nfp (nfp)
         (complex
          (sap-ref-long nfp (number-stack-offset))
          (sap-ref-long nfp
                        (number-stack-offset #+sparc 4
                                             #+(or x86 x86-64) 3)))))
      (#.sb-vm:control-stack-sc-number
       (stack-ref fp (sb-c:sc+offset-offset sc+offset)))
      (#.sb-vm:character-stack-sc-number
       (with-nfp (nfp)
         (code-char (sap-ref-word nfp (number-stack-offset)))))
      (#.sb-vm:unsigned-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-word nfp (number-stack-offset))))
      (#.sb-vm:signed-stack-sc-number
       (with-nfp (nfp)
         (signed-sap-ref-word nfp (number-stack-offset))))
      (#.sb-vm:sap-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-sap nfp (number-stack-offset))))
      (#.constant-sc-number
       (if escaped
           (code-header-ref
            (code-header-from-pc (sb-vm:context-pc escaped))
            (sb-c:sc+offset-offset sc+offset))
           :invalid-value-for-unescaped-register-storage))
      (#.immediate-sc-number
       (sb-c:sc+offset-offset sc+offset)))))

;;; This stores value as the value of DEBUG-VAR in FRAME. In the
;;; COMPILED-DEBUG-VAR case, access the current value to determine if
;;; it is an indirect value cell. This occurs when the variable is
;;; both closed over and set.
(defun %set-debug-var-value (debug-var frame new-value)
  (aver (typep frame 'compiled-frame))
  (let ((old-value (access-compiled-debug-var-slot debug-var frame)))
    (if (indirect-value-cell-p old-value)
        (value-cell-set old-value new-value)
        (set-compiled-debug-var-slot debug-var frame new-value)))
  new-value)

;;; This stores VALUE for the variable represented by debug-var
;;; relative to the frame. This assumes the location directly contains
;;; the variable's value; that is, there is no indirect value cell
;;; currently there in case the variable is both closed over and set.
(defun set-compiled-debug-var-slot (debug-var frame value)
  (let ((escaped (compiled-frame-escaped frame)))
    (if escaped
        (sub-set-debug-var-slot (frame-pointer frame)
                                (compiled-debug-var-sc+offset debug-var)
                                value escaped)
        (sub-set-debug-var-slot
         (frame-pointer frame)
         (or (compiled-debug-var-save-sc+offset debug-var)
             (compiled-debug-var-sc+offset debug-var))
         value))))

(defun sub-set-debug-var-slot (fp sc+offset value &optional escaped)
  ;; Like sub-access-debug-var-slot, this is the unification of two
  ;; divergent copy-pasted functions.  The astute reviewer will notice
  ;; that long-floats are messed up here as well, that x86oids
  ;; apparently don't support accessing float values that are in
  ;; registers, and that non-x86oids store the real part of a float
  ;; for both the real and imaginary parts of a complex on the stack
  ;; (but not in registers, oddly enough).  Some research has
  ;; indicated that the different forms of THE used for validating the
  ;; type of complex float components between x86oid and non-x86oid
  ;; systems are only significant in the case of using a non-complex
  ;; number as input (as the non-x86oid case effectively converts
  ;; non-complex numbers to complex ones and the x86oid case will
  ;; error out).  That said, the error message from entering a value
  ;; of the wrong type will be slightly easier to understand on x86oid
  ;; systems.
  (macrolet ((set-escaped-value (val)
               `(if escaped
                    (setf (sb-vm:context-register
                           escaped
                           (sb-c:sc+offset-offset sc+offset))
                          ,val)
                    value))
             (set-escaped-boxed-value (val)
               `(if escaped
                    (setf (boxed-context-register
                           escaped
                           (sb-c:sc+offset-offset sc+offset))
                          ,val)
                    value))
             (set-escaped-float-value (format val)
               `(if escaped
                    (setf (sb-vm:context-float-register
                           escaped
                           (sb-c:sc+offset-offset sc+offset)
                           ',format)
                          ,val)
                    value))
             (with-nfp ((var) &body body)
               ;; x86oids have no separate number stack, so dummy it
               ;; up for them.
               #+c-stack-is-control-stack
               `(let ((,var fp))
                  ,@body)
               #-c-stack-is-control-stack
               `(let ((,var (if escaped
                                (int-sap
                                 (sb-vm:context-register escaped
                                                         sb-vm::nfp-offset))
                                (sap-ref-sap fp
                                             (* nfp-save-offset
                                                sb-vm:n-word-bytes)))))
                  ,@body))
             (number-stack-offset (&optional (offset 0))
               #+(or x86 x86-64)
               `(+ (sb-vm::frame-byte-offset (sb-c:sc+offset-offset sc+offset))
                   ,offset)
               #-(or x86 x86-64)
               `(+ (* (sb-c:sc+offset-offset sc+offset) sb-vm:n-word-bytes)
                   ,offset)))
    (ecase (sb-c:sc+offset-scn sc+offset)
      ((#.sb-vm:any-reg-sc-number
        #.sb-vm:descriptor-reg-sc-number)
       (set-escaped-boxed-value value))
      (#.sb-vm:character-reg-sc-number
       (set-escaped-value (char-code value)))
      (#.sb-vm:sap-reg-sc-number
       (set-escaped-value (sap-int value)))
      (#.sb-vm:signed-reg-sc-number
       (set-escaped-value (logand value most-positive-word)))
      (#.sb-vm:unsigned-reg-sc-number
       (set-escaped-value value))
      #-(or x86 x86-64)
      (#.sb-vm:non-descriptor-reg-sc-number
       (error "Local non-descriptor register access?"))
      #-(or x86 x86-64)
      (#.sb-vm:interior-reg-sc-number
       (error "Local interior register access?"))
      (#.sb-vm:single-reg-sc-number
       #-(or x86 x86-64) ;; don't have escaped floats.
       (set-escaped-float-value single-float value))
      (#.sb-vm:double-reg-sc-number
       (set-escaped-float-value double-float value))
      #+long-float
      (#.sb-vm:long-reg-sc-number
       (set-escaped-float-value long-float value))
      (#.sb-vm:complex-single-reg-sc-number
       (set-escaped-float-value complex-single-float value))
      (#.sb-vm:complex-double-reg-sc-number
       (set-escaped-float-value complex-double-float value))
      #+long-float
      (#.sb-vm:complex-long-reg-sc-number
       (set-escaped-float-value complex-long-float))
      (#.sb-vm:single-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-single nfp (number-stack-offset))
               (the single-float value))))
      (#.sb-vm:double-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-double nfp (number-stack-offset))
               (the double-float value))))
      #+long-float
      (#.sb-vm:long-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-long nfp (number-stack-offset))
               (the long-float value))))
      (#.sb-vm:complex-single-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-single nfp (number-stack-offset))
               #+(or x86 x86-64)
               (realpart (the (complex single-float) value))
               #-(or x86 x86-64)
               (the single-float (realpart value)))
         (setf (sap-ref-single nfp (number-stack-offset 4))
               #+(or x86 x86-64)
               (imagpart (the (complex single-float) value))
               #-(or x86 x86-64)
               (the single-float (realpart value)))))
      (#.sb-vm:complex-double-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-double nfp (number-stack-offset))
               #+(or x86 x86-64)
               (realpart (the (complex double-float) value))
               #-(or x86 x86-64)
               (the double-float (realpart value)))
         (setf (sap-ref-double nfp (number-stack-offset 8))
               #+(or x86 x86-64)
               (imagpart (the (complex double-float) value))
               #-(or x86 x86-64)
               (the double-float (realpart value)))))
      #+long-float
      (#.sb-vm:complex-long-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-long
                nfp (number-stack-offset))
               #+(or x86 x86-64)
               (realpart (the (complex long-float) value))
               #-(or x86 x86-64)
               (the long-float (realpart value)))
         (setf (sap-ref-long
                nfp (number-stack-offset #+sparc 4
                                        #+(or x86 x86-64) 3))
               #+(or x86 x86-64)
               (imagpart (the (complex long-float) value))
               #-(or x86 x86-64)
               (the long-float (realpart value)))))
      (#.sb-vm:control-stack-sc-number
       (setf (stack-ref fp (sb-c:sc+offset-offset sc+offset)) value))
      (#.sb-vm:character-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-word nfp (number-stack-offset 0))
               (char-code (the character value)))))
      (#.sb-vm:unsigned-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-word nfp (number-stack-offset 0)) (the word value))))
      (#.sb-vm:signed-stack-sc-number
       (with-nfp (nfp)
         (setf (signed-sap-ref-word nfp (number-stack-offset))
               (the signed-word value))))
      (#.sb-vm:sap-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-sap nfp (number-stack-offset))
               (the system-area-pointer value)))))))

;;; The method for setting and accessing COMPILED-DEBUG-VAR values use
;;; this to determine if the value stored is the actual value or an
;;; indirection cell.
(defun indirect-value-cell-p (x)
  (and (%other-pointer-p x)
       (eql (%other-pointer-widetag x) sb-vm:value-cell-widetag)))

;;; Return three values reflecting the validity of DEBUG-VAR's value
;;; at BASIC-CODE-LOCATION:
;;;   :VALID    The value is known to be available.
;;;   :INVALID  The value is known to be unavailable.
;;;   :UNKNOWN  The value's availability is unknown.
;;;
;;; If the variable is always alive, then it is valid. If the
;;; code-location is unknown, then the variable's validity is
;;; :unknown. Once we've called CODE-LOCATION-UNKNOWN-P, we know the
;;; live-set information has been cached in the code-location.
(defun debug-var-validity (debug-var basic-code-location)
  (compiled-debug-var-validity debug-var basic-code-location))

(defun debug-var-info (debug-var)
  (compiled-debug-var-info debug-var))

;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs.
;;; For safety, make sure basic-code-location is what we think.
(defun compiled-debug-var-validity (debug-var basic-code-location)
  (declare (type compiled-code-location basic-code-location))
  (cond ((debug-var-alive-p debug-var)
         (let ((debug-fun (code-location-debug-fun basic-code-location)))
           (if (>= (compiled-code-location-pc basic-code-location)
                   (sb-c::compiled-debug-fun-start-pc
                    (compiled-debug-fun-compiler-debug-fun debug-fun)))
               :valid
               :invalid)))
        ((code-location-unknown-p basic-code-location) :unknown)
        (t
         (let ((pos (position debug-var
                              (debug-fun-debug-vars
                               (code-location-debug-fun
                                basic-code-location)))))
           (unless pos
             (error 'unknown-debug-var
                    :debug-var debug-var
                    :debug-fun
                    (code-location-debug-fun basic-code-location)))
           ;; There must be live-set info since basic-code-location is known.
           (if (zerop (sbit (compiled-code-location-live-set
                             basic-code-location)
                            pos))
               :invalid
               :valid)))))

;;;; sources

;;; This code produces and uses what we call source-paths. A
;;; source-path is a list whose first element is a form number as
;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a
;;; top level form number as returned by
;;; CODE-LOCATION-TOPLEVEL-FORM-NUMBER. The elements from the last to
;;; the first, exclusively, are the numbered subforms into which to
;;; descend. For example:
;;;    (defun foo (x)
;;;      (let ((a (aref x 3)))
;;;     (cons a 3)))
;;; The call to AREF in this example is form number 5. Assuming this
;;; DEFUN is the 11'th top level form, the source-path for the AREF
;;; call is as follows:
;;;    (5 1 0 1 3 11)
;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
;;; gets the first binding, and 1 gets the AREF form.

;;; This returns a table mapping form numbers to source-paths. A
;;; source-path indicates a descent into the TOPLEVEL-FORM form,
;;; going directly to the subform corressponding to the form number.
;;;
;;; The vector elements are in the same format as the compiler's
;;; NODE-SOURCE-PATH; that is, the first element is the form number and
;;; the last is the TOPLEVEL-FORM number.
;;;
;;; This should be synchronized with SB-C::SUB-FIND-SOURCE-PATHS
(defun form-number-translations (form tlf-number)
  (let ((seen nil)
        (translations (make-array 12 :fill-pointer 0 :adjustable t)))
    (labels ((translate1 (form path)
               (unless (member form seen)
                 (push form seen)
                 (vector-push-extend (cons (fill-pointer translations) path)
                                     translations)
                 (let ((pos 0)
                       (subform form)
                       (trail form))
                   (declare (fixnum pos))
                   (macrolet ((frob ()
                                '(progn
                                  (when (atom subform) (return))
                                  (let ((fm (car subform)))
                                    (when (comma-p fm)
                                      (setf fm (comma-expr fm)))
                                    (cond ((consp fm)
                                           (translate1 fm (cons pos path)))
                                          ((eq 'quote fm)
                                           ;; Don't look into quoted constants.
                                           (return)))
                                    (incf pos))
                                  (setq subform (cdr subform))
                                  (when (eq subform trail) (return)))))
                     (loop
                       (frob)
                       (frob)
                       (setq trail (cdr trail))))))))
      (translate1 form (list tlf-number)))
    (coerce translations 'simple-vector)))

;;; FORM is a top level form, and path is a source-path into it. This
;;; returns the form indicated by the source-path. Context is the
;;; number of enclosing forms to return instead of directly returning
;;; the source-path form. When context is non-zero, the form returned
;;; contains a marker, #:****HERE****, immediately before the form
;;; indicated by path.
(defun source-path-context (form path context)
  (declare (type unsigned-byte context))
  ;; Get to the form indicated by path or the enclosing form indicated
  ;; by context and path.
  (let ((path (reverse (butlast (cdr path)))))
    (dotimes (i (- (length path) context))
      (let ((index (first path)))
        (unless (and (listp form) (< index (length form)))
          (error "Source path no longer exists."))
        (setq form (elt form index))
        (setq path (rest path))))
    ;; Recursively rebuild the source form resulting from the above
    ;; descent, copying the beginning of each subform up to the next
    ;; subform we descend into according to path. At the bottom of the
    ;; recursion, we return the form indicated by path preceded by our
    ;; marker, and this gets spliced into the resulting list structure
    ;; on the way back up.
    (labels ((frob (form path level)
               (if (or (zerop level) (null path))
                   (if (zerop context)
                       form
                       `(#:***here*** ,form))
                   (let ((n (first path)))
                     (unless (and (listp form) (< n (length form)))
                       (error "Source path no longer exists."))
                     (let ((res (frob (elt form n) (rest path) (1- level))))
                       (nconc (subseq form 0 n)
                              (cons res (nthcdr (1+ n) form))))))))
      (frob form path context))))

;;; Given a code location, return the associated form-number
;;; translations and the actual top level form.
;;; Note that functions compiled to memory (via COMPILE or implicitly
;;; via LOAD if *EVALUATOR-MODE* = :COMPILE) do not save their source form
;;; in the DEBUG-SOURCE corresponding to their code-component. Instead the
;;; form hangs off the %SIMPLE-FUN-INFO slot, so that we can get an accurate
;;; depiction of the source form for any lambda no matter where from.
(defun get-toplevel-form (location)
  (let ((d-source (code-location-debug-source location)))
    (let* ((offset (code-location-toplevel-form-offset location))
           (res
             (cond ((and (core-debug-source-p d-source)
                         (core-debug-source-form d-source)))
                   ((debug-source-namestring d-source)
                    (get-file-toplevel-form location))
                   (t (bug "Don't know how to use a DEBUG-SOURCE without ~
                               a namestring or a form.")))))
      (values (form-number-translations res offset) res))))

;;; To suppress the read-time evaluation #. macro during source read,
;;; *READTABLE* is modified.
;;;
;;; FIXME: This breaks #+#.(cl:if ...) Maybe we need a SAFE-READ-EVAL, which
;;; this code can use for side- effect free #. calls?
;;;
;;; FIXME: This also knows nothing of custom readtables. The assumption
;;; is that the current readtable is a decent approximation for what
;;; we want, but that's lossy.
(defun safe-readtable ()
  (let ((rt (copy-readtable)))
    (set-dispatch-macro-character
     #\# #\. (lambda (stream sub-char &rest rest)
               (declare (ignore rest sub-char))
               (let ((token (read stream t nil t)))
                 (format nil "#.~S" token)))
     rt)
    rt))

;;; Locate the source file (if it still exists) and grab the top level
;;; form. If the file is modified, we use the top level form offset
;;; instead of the recorded character offset.
(defun get-file-toplevel-form (location)
  (let* ((d-source (code-location-debug-source location))
         (di (compiled-debug-fun-debug-info
              (code-location-debug-fun location)))
         (tlf-offset (sb-c::compiled-debug-info-tlf-number di))
         (char-offset (sb-c::compiled-debug-info-char-offset di))
         (namestring (debug-source-namestring d-source)))
    ;; FIXME: External format?
    (with-open-file (f namestring :if-does-not-exist nil)
      (when f
        (let ((*readtable* (safe-readtable)))
          (cond ((eql (debug-source-created d-source) (file-write-date f))
                 (file-position f char-offset))
                (t
                 (format *debug-io*
                         "~%; File has been modified since compilation:~%;   ~A~@
                          ; Using form offset instead of character position.~%"
                         namestring)
                 (let ((*read-suppress* t))
                   (loop repeat tlf-offset
                         do (read f)))))
          (read f))))))

;;;; PREPROCESS-FOR-EVAL

;;; Return a function of one argument that evaluates form in the
;;; lexical context of the BASIC-CODE-LOCATION LOC, or signal a
;;; NO-DEBUG-VARS condition when the LOC's DEBUG-FUN has no
;;; DEBUG-VAR information available.
;;;
;;; The returned function takes the frame to get values from as its
;;; argument, and it returns the values of FORM. The returned function
;;; can signal the following conditions: INVALID-VALUE,
;;; AMBIGUOUS-VAR-NAME, and FRAME-FUN-MISMATCH.
(defun preprocess-for-eval (form loc)
  (declare (type code-location loc))
  (let ((n-frame (gensym))
        (fun (code-location-debug-fun loc))
        (more-context nil)
        (more-count nil))
    (unless (debug-var-info-available fun)
      (debug-signal 'no-debug-vars :debug-fun fun))
    (collect ((binds)
              (specs))
      (do-debug-fun-vars (var fun)
        (let ((validity (debug-var-validity var loc)))
          (unless (eq validity :invalid)
            (case (debug-var-info var)
              (:more-context
               (setf more-context var))
              (:more-count
               (setf more-count var))
              (t
               (let* ((sym (debug-var-symbol var))
                      (found (assoc sym (binds))))
                 (cond ((not sym))
                       (found
                        (setf (second found) :ambiguous))
                       (t
                        (binds (list sym validity var))))))))))
      (when (and more-context more-count)
        (let ((more (assoc 'sb-debug::more (binds))))
          (if more
              (setf (second more) :ambiguous)
              (binds (list 'sb-debug::more :more more-context more-count)))))
      (dolist (bind (binds))
        (let ((name (first bind))
              (var (third bind)))
          (unless (eq (info :variable :kind name) :special)
            (ecase (second bind)
              (:valid
               (specs `(,name (debug-var-value ',var ,n-frame))))
              (:more
               (let ((count-var (fourth bind)))
                 (specs `(,name (multiple-value-list
                                 (sb-c:%more-arg-values (debug-var-value ',var ,n-frame)
                                                        0
                                                        (debug-var-value ',count-var ,n-frame)))))))
              (:unknown
               (specs `(,name (debug-signal 'invalid-value
                                            :debug-var ',var
                                            :frame ,n-frame))))
              (:ambiguous
               (specs `(,name (debug-signal 'ambiguous-var-name
                                            :name ',name
                                            :frame ,n-frame))))))))
      ;; Process the symbol macros outside of the function to avoid
      ;; all those symbol-macrolets from showing in the sources if
      ;; there is a problem evaluating this form
      (let ((res (let ((sb-c:*lexenv* (make-null-lexenv)))
                   (sb-c::funcall-in-symbol-macrolet-lexenv
                    (specs)
                    (lambda (&optional vars)
                      (declare (ignore vars))
                      (eval-in-lexenv `(lambda (,n-frame)
                                         (declare (ignorable ,n-frame))
                                         (progn ,form))
                                      sb-c:*lexenv*))
                    :eval))))
        (lambda (frame)
          ;; This prevents these functions from being used in any
          ;; location other than a function return location, so maybe
          ;; this should only check whether FRAME's DEBUG-FUN is the
          ;; same as LOC's.
          (unless (code-location= (frame-code-location frame) loc)
            (debug-signal 'frame-fun-mismatch
                          :code-location loc :form form :frame frame))
          (funcall res frame))))))

;;; EVAL-IN-FRAME

(defun eval-in-frame (frame form)
  (declare (type frame frame))
  "Evaluate FORM in the lexical context of FRAME's current code location,
   returning the results of the evaluation."
  (funcall (preprocess-for-eval form (frame-code-location frame)) frame))

;;;; breakpoints

;;;; user-visible interface

;;; Create and return a breakpoint. When program execution encounters
;;; the breakpoint, the system calls HOOK-FUN. HOOK-FUN takes the
;;; current frame for the function in which the program is running and
;;; the breakpoint object.
;;;
;;; WHAT and KIND determine where in a function the system invokes
;;; HOOK-FUN. WHAT is either a code-location or a DEBUG-FUN. KIND is
;;; one of :CODE-LOCATION, :FUN-START, or :FUN-END. Since the starts
;;; and ends of functions may not have code-locations representing
;;; them, designate these places by supplying WHAT as a DEBUG-FUN and
;;; KIND indicating the :FUN-START or :FUN-END. When WHAT is a
;;; DEBUG-FUN and kind is :FUN-END, then HOOK-FUN must take two
;;; additional arguments, a list of values returned by the function
;;; and a FUN-END-COOKIE.
;;;
;;; INFO is information supplied by and used by the user.
;;;
;;; FUN-END-COOKIE is a function. To implement :FUN-END
;;; breakpoints, the system uses starter breakpoints to establish the
;;; :FUN-END breakpoint for each invocation of the function. Upon
;;; each entry, the system creates a unique cookie to identify the
;;; invocation, and when the user supplies a function for this
;;; argument, the system invokes it on the frame and the cookie. The
;;; system later invokes the :FUN-END breakpoint hook on the same
;;; cookie. The user may save the cookie for comparison in the hook
;;; function.
;;;
;;; Signal an error if WHAT is an unknown code-location.
(defun make-breakpoint (hook-fun what
                        &key (kind :code-location) info fun-end-cookie)
  (etypecase what
    (code-location
     (when (code-location-unknown-p what)
       (error "cannot make a breakpoint at an unknown code location: ~S"
              what))
     (aver (eq kind :code-location))
     (let ((bpt (%make-breakpoint hook-fun what kind info)))
       (etypecase what
         (compiled-code-location
          ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
          (when (eq (compiled-code-location-kind what) :unknown-return)
            (let ((other-bpt (%make-breakpoint hook-fun what
                                               :unknown-return-partner
                                               info)))
              (setf (breakpoint-unknown-return-partner bpt) other-bpt)
              (setf (breakpoint-unknown-return-partner other-bpt) bpt))))
         ;; (There used to be more cases back before sbcl-0.7.0,,
         ;; when we did special tricks to debug the IR1
         ;; interpreter.)
         )
       bpt))
    (compiled-debug-fun
     (ecase kind
       (:fun-start
        (%make-breakpoint hook-fun what kind info))
       (:fun-end
        (unless (eq (sb-c::compiled-debug-fun-returns
                     (compiled-debug-fun-compiler-debug-fun what))
                    :standard)
          (error ":FUN-END breakpoints are currently unsupported ~
                  for the known return convention."))

        (let* ((bpt (%make-breakpoint hook-fun what kind info))
               (starter (compiled-debug-fun-end-starter what)))
          (unless starter
            (setf starter (%make-breakpoint #'list what :fun-start nil))
            (setf (breakpoint-hook-fun starter)
                  (fun-end-starter-hook starter what))
            (setf (compiled-debug-fun-end-starter what) starter))
          (setf (breakpoint-start-helper bpt) starter)
          (push bpt (breakpoint-%info starter))
          (setf (breakpoint-cookie-fun bpt) fun-end-cookie)
          bpt))))))

;;; These are unique objects created upon entry into a function by a
;;; :FUN-END breakpoint's starter hook. These are only created
;;; when users supply :FUN-END-COOKIE to MAKE-BREAKPOINT. Also,
;;; the :FUN-END breakpoint's hook is called on the same cookie
;;; when it is created.
(defstruct (fun-end-cookie
            (:print-object (lambda (obj str)
                             (print-unreadable-object (obj str :type t))))
            (:constructor make-fun-end-cookie (bpt-lra debug-fun))
            (:copier nil))
  ;; a pointer to the bpt-lra created for :FUN-END breakpoints
  (bpt-lra nil :read-only t)
  ;; the DEBUG-FUN associated with this cookie
  (debug-fun nil :read-only t))

;;; This maps bpt-lra objects to cookies, so that
;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the
;;; breakpoint hook.
;;; FIXME: assuming the preceding comment is correct, this seems an incredibly bad
;;; way to store the data. Why not just allocate an additional boxed slot in every
;;; bpt-lra object to store its cookies? Why use a hash table?
(define-load-time-global *fun-end-cookies*
    (make-hash-table :test 'eq :synchronized t))

;;; This returns a hook function for the start helper breakpoint
;;; associated with a :FUN-END breakpoint. The returned function
;;; makes a fake LRA that all returns go through, and this piece of
;;; fake code actually breaks. Upon return from the break, the code
;;; provides the returnee with any values. Since the returned function
;;; effectively activates FUN-END-BPT on each entry to DEBUG-FUN's
;;; function, we must establish breakpoint-data about FUN-END-BPT.
(defun fun-end-starter-hook (starter-bpt debug-fun)
  (declare (type breakpoint starter-bpt)
           (type compiled-debug-fun debug-fun))
  (lambda (frame breakpoint)
    (declare (ignore breakpoint)
             (type frame frame))
    (multiple-value-bind (lra component offset)
        (make-bpt-lra (frame-saved-lra frame debug-fun))
      (setf (frame-saved-lra frame debug-fun) lra)
      (let ((end-bpts (breakpoint-%info starter-bpt)))
        (let ((data (breakpoint-data component offset)))
          (setf (breakpoint-data-breakpoints data) end-bpts)
          (dolist (bpt end-bpts)
            (setf (breakpoint-internal-data bpt) data)))
        (let ((cookie (make-fun-end-cookie lra debug-fun)))
          (setf (gethash component *fun-end-cookies*) cookie)
          (dolist (bpt end-bpts)
            (let ((fun (breakpoint-cookie-fun bpt)))
              (when fun (funcall fun frame cookie)))))))))

;;; This takes a FUN-END-COOKIE and a frame, and it returns
;;; whether the cookie is still valid. A cookie becomes invalid when
;;; the frame that established the cookie has exited. Sometimes cookie
;;; holders are unaware of cookie invalidation because their
;;; :FUN-END breakpoint hooks didn't run due to THROW'ing.
;;;
;;; This takes a frame as an efficiency hack since the user probably
;;; has a frame object in hand when using this routine, and it saves
;;; repeated parsing of the stack and consing when asking whether a
;;; series of cookies is valid.
(defun fun-end-cookie-valid-p (frame cookie)
  (let ((lra (fun-end-cookie-bpt-lra cookie)))
    (do ((frame frame (frame-down frame)))
        ((not frame) nil)
      (when (and (compiled-frame-p frame)
                 (#-(or x86 x86-64) eq #+(or x86 x86-64) sap=
                  lra
                  (frame-saved-lra frame (frame-debug-fun frame))))
        (return t)))))

;;;; ACTIVATE-BREAKPOINT

;;; Cause the system to invoke the breakpoint's hook function until
;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The
;;; system invokes breakpoint hook functions in the opposite order
;;; that you activate them.
(defun activate-breakpoint (breakpoint)
  (when (eq (breakpoint-status breakpoint) :deleted)
    (error "cannot activate a deleted breakpoint: ~S" breakpoint))
  (unless (eq (breakpoint-status breakpoint) :active)
    (ecase (breakpoint-kind breakpoint)
      (:code-location
       (let ((loc (breakpoint-what breakpoint)))
         (etypecase loc
           (compiled-code-location
            (activate-compiled-code-location-breakpoint breakpoint)
            (let ((other (breakpoint-unknown-return-partner breakpoint)))
              (when other
                (activate-compiled-code-location-breakpoint other))))
           ;; (There used to be more cases back before sbcl-0.7.0, when
           ;; we did special tricks to debug the IR1 interpreter.)
           )))
      (:fun-start
       (etypecase (breakpoint-what breakpoint)
         (compiled-debug-fun
          (activate-compiled-fun-start-breakpoint breakpoint))
         ;; (There used to be more cases back before sbcl-0.7.0, when
         ;; we did special tricks to debug the IR1 interpreter.)
         ))
      (:fun-end
       (etypecase (breakpoint-what breakpoint)
         (compiled-debug-fun
          (let ((starter (breakpoint-start-helper breakpoint)))
            (unless (eq (breakpoint-status starter) :active)
              ;; may already be active by some other :FUN-END breakpoint
              (activate-compiled-fun-start-breakpoint starter)))
          (setf (breakpoint-status breakpoint) :active))
         ;; (There used to be more cases back before sbcl-0.7.0, when
         ;; we did special tricks to debug the IR1 interpreter.)
         ))))
  breakpoint)

(defun activate-compiled-code-location-breakpoint (breakpoint)
  (declare (type breakpoint breakpoint))
  (let ((loc (breakpoint-what breakpoint)))
    (declare (type compiled-code-location loc))
    (sub-activate-breakpoint
     breakpoint
     (breakpoint-data (compiled-debug-fun-component
                       (code-location-debug-fun loc))
                      (+ (compiled-code-location-pc loc)
                         (if (or (eq (breakpoint-kind breakpoint)
                                     :unknown-return-partner)
                                 (eq (compiled-code-location-kind loc)
                                     :single-value-return))
                             sb-vm:single-value-return-byte-offset
                             0))))))

(defun activate-compiled-fun-start-breakpoint (breakpoint)
  (declare (type breakpoint breakpoint))
  (let ((debug-fun (breakpoint-what breakpoint)))
    (sub-activate-breakpoint
     breakpoint
     (breakpoint-data (compiled-debug-fun-component debug-fun)
                      (sb-c::compiled-debug-fun-start-pc
                       (compiled-debug-fun-compiler-debug-fun
                        debug-fun))))))

(defun sub-activate-breakpoint (breakpoint data)
  (declare (type breakpoint breakpoint)
           (type breakpoint-data data))
  (setf (breakpoint-status breakpoint) :active)
  (without-interrupts
   (unless (breakpoint-data-breakpoints data)
     (let ((code (breakpoint-data-component data)))
       (with-pinned-objects (code)
         (setf (breakpoint-data-instruction data)
               (breakpoint-install (get-lisp-obj-address code)
                                   (breakpoint-data-offset data))))))
   (setf (breakpoint-data-breakpoints data)
         (append (breakpoint-data-breakpoints data) (list breakpoint)))
   (setf (breakpoint-internal-data breakpoint) data)))

;;;; DEACTIVATE-BREAKPOINT

;;; Stop the system from invoking the breakpoint's hook function.
(defun deactivate-breakpoint (breakpoint)
  (when (eq (breakpoint-status breakpoint) :active)
    (without-interrupts
     (let ((loc (breakpoint-what breakpoint)))
       (etypecase loc
         ((or compiled-code-location compiled-debug-fun)
          (deactivate-compiled-breakpoint breakpoint)
          (let ((other (breakpoint-unknown-return-partner breakpoint)))
            (when other
              (deactivate-compiled-breakpoint other))))
         ;; (There used to be more cases back before sbcl-0.7.0, when
         ;; we did special tricks to debug the IR1 interpreter.)
         ))))
  breakpoint)

(defun deactivate-compiled-breakpoint (breakpoint)
  (if (eq (breakpoint-kind breakpoint) :fun-end)
      (let ((starter (breakpoint-start-helper breakpoint)))
        (unless (find-if (lambda (bpt)
                           (and (not (eq bpt breakpoint))
                                (eq (breakpoint-status bpt) :active)))
                         (breakpoint-%info starter))
          (deactivate-compiled-breakpoint starter)))
      (let* ((data (breakpoint-internal-data breakpoint))
             (bpts (delete breakpoint (breakpoint-data-breakpoints data))))
        (setf (breakpoint-internal-data breakpoint) nil)
        (setf (breakpoint-data-breakpoints data) bpts)
        (unless bpts
          (let ((code (breakpoint-data-component data)))
            (with-pinned-objects (code)
              (breakpoint-remove (get-lisp-obj-address code)
                                 (breakpoint-data-offset data)
                                 (breakpoint-data-instruction data))))
          (delete-breakpoint-data data))))
  (setf (breakpoint-status breakpoint) :inactive)
  breakpoint)

;;;; BREAKPOINT-INFO

;;; Return the user-maintained info associated with breakpoint. This
;;; is SETF'able.
(defun breakpoint-info (breakpoint)
  (breakpoint-%info breakpoint))
(defun %set-breakpoint-info (breakpoint value)
  (setf (breakpoint-%info breakpoint) value)
  (let ((other (breakpoint-unknown-return-partner breakpoint)))
    (when other
      (setf (breakpoint-%info other) value))))

;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT

(defun breakpoint-active-p (breakpoint)
  (ecase (breakpoint-status breakpoint)
    (:active t)
    ((:inactive :deleted) nil)))

;;; Free system storage and remove computational overhead associated
;;; with breakpoint. After calling this, breakpoint is completely
;;; impotent and can never become active again.
(defun delete-breakpoint (breakpoint)
  (let ((status (breakpoint-status breakpoint)))
    (unless (eq status :deleted)
      (when (eq status :active)
        (deactivate-breakpoint breakpoint))
      (setf (breakpoint-status breakpoint) :deleted)
      (let ((other (breakpoint-unknown-return-partner breakpoint)))
        (when other
          (setf (breakpoint-status other) :deleted)))
      (when (eq (breakpoint-kind breakpoint) :fun-end)
        (let* ((starter (breakpoint-start-helper breakpoint))
               (breakpoints (delete breakpoint
                                    (the list (breakpoint-info starter)))))
          (setf (breakpoint-info starter) breakpoints)
          (unless breakpoints
            (delete-breakpoint starter)
            (setf (compiled-debug-fun-end-starter
                   (breakpoint-what breakpoint))
                  nil))))))
  breakpoint)

;;;; C call out stubs

;;; This actually installs the break instruction in the component. It
;;; returns the overwritten bits. You must call this in a context in
;;; which GC is disabled, so that Lisp doesn't move objects around
;;; that C is pointing to.
(sb-alien:define-alien-routine "breakpoint_install" sb-alien:unsigned-int
  (code-obj sb-alien:unsigned)
  (pc-offset sb-alien:int))

;;; This removes the break instruction and replaces the original
;;; instruction. You must call this in a context in which GC is disabled
;;; so Lisp doesn't move objects around that C is pointing to.
(sb-alien:define-alien-routine "breakpoint_remove" sb-alien:void
  (code-obj sb-alien:unsigned)
  (pc-offset sb-alien:int)
  (old-inst sb-alien:unsigned-int))

(sb-alien:define-alien-routine "breakpoint_do_displaced_inst" sb-alien:void
  (scp (* os-context-t))
  (orig-inst sb-alien:unsigned-int))

;;;; breakpoint handlers (layer between C and exported interface)

;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs.
(define-load-time-global *component-breakpoint-offsets*
    (make-hash-table :test 'eq :synchronized t))

;;; This returns the BREAKPOINT-DATA object associated with component cross
;;; offset. If none exists, this makes one, installs it, and returns it.
(defun breakpoint-data (component offset &optional (create t))
  (aver component)
  (flet ((install-breakpoint-data ()
           ;; Well, this has at least these three problems if not more:
           ;; 1. For the double-checked lock pattern to be correct we have to
           ;;    re-check whether a key is in the table within the scope of the lock.
           ;; 2. The push should probably be a PUSHNEW, but even better, it too
           ;;    needs to be locked or else dups can occur. Maybe use our newfangled
           ;;    ordered lockfree linked lists.
           ;; 3. The hash-table should probably be weak keyed
           (when create
             (let ((data (make-breakpoint-data component offset)))
               (push (cons offset data)
                     (gethash component *component-breakpoint-offsets*))
               data))))
    (let ((offsets (gethash component *component-breakpoint-offsets*)))
      (if offsets
          (let ((data (assoc offset offsets)))
            (if data
                (cdr data)
                (install-breakpoint-data)))
          (install-breakpoint-data)))))

;;; We use this when there are no longer any active breakpoints
;;; corresponding to DATA.
(defun delete-breakpoint-data (data)
  ;; Again, this looks brittle. Is there no danger of being interrupted
  ;; here?
  (let* ((component (breakpoint-data-component data))
         (offsets (delete (breakpoint-data-offset data)
                          (gethash component *component-breakpoint-offsets*)
                          :key #'car)))
    (if offsets
        (setf (gethash component *component-breakpoint-offsets*) offsets)
        (remhash component *component-breakpoint-offsets*)))
  (values))

;;; The C handler for interrupts calls this when it has a
;;; debugging-tool break instruction. This does *not* handle all
;;; breaks; for example, it does not handle breaks for internal
;;; errors.
(defun handle-breakpoint (offset component signal-context)
  (let ((data (breakpoint-data component offset nil)))
    (unless data
      (error "unknown breakpoint in ~S at offset ~S"
              (debug-fun-name (debug-fun-from-pc component offset))
              offset))
    (let ((breakpoints (breakpoint-data-breakpoints data)))
      (if (or (null breakpoints)
              (eq (breakpoint-kind (car breakpoints)) :fun-end))
          (handle-fun-end-breakpoint-aux breakpoints data signal-context)
          (handle-breakpoint-aux breakpoints data
                                 offset component signal-context)))))

;;; This holds breakpoint-datas while invoking the breakpoint hooks
;;; associated with that particular component and location. While they
;;; are executing, if we hit the location again, we ignore the
;;; breakpoint to avoid infinite recursion. fun-end breakpoints
;;; must work differently since the breakpoint-data is unique for each
;;; invocation.
(defvar *executing-breakpoint-hooks* nil)

;;; This handles code-location and DEBUG-FUN :FUN-START
;;; breakpoints.
(defun handle-breakpoint-aux (breakpoints data offset component signal-context)
  (unless breakpoints
    (bug "breakpoint that nobody wants"))
  (unless (member data *executing-breakpoint-hooks*)
    (let ((*executing-breakpoint-hooks* (cons data
                                              *executing-breakpoint-hooks*)))
      (invoke-breakpoint-hooks breakpoints signal-context)))
  ;; At this point breakpoints may not hold the same list as
  ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed
  ;; a breakpoint deactivation. In fact, if all breakpoints were
  ;; deactivated then data is invalid since it was deleted and so the
  ;; correct one must be looked up if it is to be used. If there are
  ;; no more breakpoints active at this location, then the normal
  ;; instruction has been put back, and we do not need to
  ;; DO-DISPLACED-INST.
  (setf data (breakpoint-data component offset nil))
  (when (and data (breakpoint-data-breakpoints data))
    ;; The breakpoint is still active, so we need to execute the
    ;; displaced instruction and leave the breakpoint instruction
    ;; behind. The best way to do this is different on each machine,
    ;; so we just leave it up to the C code.
    (breakpoint-do-displaced-inst signal-context
                                  (breakpoint-data-instruction data))
    ;; Some platforms have no usable sigreturn() call.  If your
    ;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
    ;; it's polite to warn here
    #+(and sparc solaris)
    (error "BREAKPOINT-DO-DISPLACED-INST returned?")))

(defun invoke-breakpoint-hooks (breakpoints signal-context)
  (let* ((frame (signal-context-frame signal-context)))
    (dolist (bpt breakpoints)
      (funcall (breakpoint-hook-fun bpt)
               frame
               ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
               ;; hook function the original breakpoint, so that users
               ;; aren't forced to confront the fact that some
               ;; breakpoints really are two.
               (if (eq (breakpoint-kind bpt) :unknown-return-partner)
                   (breakpoint-unknown-return-partner bpt)
                   bpt)))))

(defun signal-context-frame (signal-context)
  (let* ((scp (sb-alien:sap-alien signal-context (* os-context-t)))
         (cfp (int-sap (sb-vm:context-register scp sb-vm::cfp-offset))))
    (compute-calling-frame cfp
                           ;; KLUDGE: This argument is ignored on
                           ;; x86oids in this scenario, but is
                           ;; declared to be a SAP.
                           #+(or x86 x86-64) (sb-vm:context-pc scp)
                           #-(or x86 x86-64) nil
                           nil)))

(defun handle-fun-end-breakpoint (offset component context)
  (let ((data (breakpoint-data component offset nil)))
    (unless data
      (error "unknown breakpoint in ~S at offset ~S"
              (debug-fun-name (debug-fun-from-pc component offset))
              offset))
    (let ((breakpoints (breakpoint-data-breakpoints data)))
      (when breakpoints
        (aver (eq (breakpoint-kind (car breakpoints)) :fun-end))
        (handle-fun-end-breakpoint-aux breakpoints data context)))))

;;; Either HANDLE-BREAKPOINT calls this for :FUN-END breakpoints
;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly
;;; [new C code].
(defun handle-fun-end-breakpoint-aux (breakpoints data signal-context)
  ;; FIXME: This looks brittle: what if we are interrupted somewhere
  ;; here? ...or do we have interrupts disabled here?
  (delete-breakpoint-data data)
  (let* ((scp (sb-alien:sap-alien signal-context (* os-context-t)))
         (frame (signal-context-frame signal-context))
         (component (breakpoint-data-component data))
         (cookie (gethash component *fun-end-cookies*)))
    (remhash component *fun-end-cookies*)
    (dolist (bpt breakpoints)
      (funcall (breakpoint-hook-fun bpt)
               frame bpt
               (get-fun-end-breakpoint-values scp)
               cookie))))

(defun get-fun-end-breakpoint-values (scp)
  (let ((ocfp (int-sap (sb-vm:context-register
                        scp
                        #-(or x86 x86-64) sb-vm::ocfp-offset
                        #+x86-64 sb-vm::rbx-offset
                        #+x86 sb-vm::ebx-offset)))
        (nargs (boxed-context-register scp sb-vm::nargs-offset))
        (reg-arg-offsets '#.sb-vm::*register-arg-offsets*)
        (results nil))
    (dotimes (arg-num nargs)
      (push (if reg-arg-offsets
                (boxed-context-register scp (pop reg-arg-offsets))
                (stack-ref ocfp (+ arg-num
                                   #+(or x86 x86-64) sb-vm::sp->fp-offset)))
            results))
    (nreverse results)))

;;;; MAKE-BPT-LRA (used for :FUN-END breakpoints)

;;; Make a breakpoint LRA object that signals a breakpoint trap when returned to.
;;; If the breakpoint trap handler returns, REAL-LRA is returned to.
;;; Three values are returned: the new LRA object, the code component it is part of,
;;; and the PC offset for the trap instruction.
;;; Note: you can't cache these, because object identity confers a full dynamic
;;; state of the program, not merely a return PC location.
;;; (I tried changing this to DEFUN-CACHED, which failed a regression test)
(defun make-bpt-lra (real-lra)
  (declare (type #-(or x86 x86-64) lra #+(or x86 x86-64) system-area-pointer real-lra))
  (macrolet ((symbol-addr (name)
               `(find-dynamic-foreign-symbol-address ,name))
             (trap-offset ()
               `(- (symbol-addr "fun_end_breakpoint_trap") src-start)))
    ;; These are really code labels, not variables: but this way we get
    ;; their addresses.
    (let* ((src-start (symbol-addr "fun_end_breakpoint_guts"))
           (length (the index (- (symbol-addr "fun_end_breakpoint_end")
                                 src-start)))
           (code-object
            (sb-c:allocate-code-object
             nil 0
             ;; For non-x86: a single boxed constant holds the true LRA.
             ;; For x86[-64]: one boxed constant holds the code object to which
             ;; to return, and one holds the displacement into that object.
             ;; Ensure required boxed header alignment.
             (align-up (+ sb-vm:code-constants-offset 1 #+(or x86-64 x86) 1)
                       sb-c::code-boxed-words-align)
             ;; 2 extra raw bytes represent CODE-N-ENTRIES (which is zero)
             (+ length 2))))
      (setf (%code-debug-info code-object) :bpt-lra)
      (with-pinned-objects (code-object)
        (system-area-ub8-copy (int-sap src-start) 0
                              (code-instructions code-object) 0 length))
      #+(or x86 x86-64)
      (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra)
        (setf (code-header-ref code-object real-lra-slot) code
              (code-header-ref code-object (1+ real-lra-slot)) offset)
        ;; Holy hell, returning a SAP looks GC-unsafe, but it's OK.
        ;; It points into CODE-OBJECT which is implicitly pinned.
        ;; WITHOUT-GCING which formerly enclosed this function was disingenuous
        ;; because we escaped from its scope when returning the SAP.
        (values (code-instructions code-object) code-object (trap-offset)))
      #-(or x86 x86-64)
      (progn
        ;; We used to set the header value of the LRA here to the
        ;; offset from the enclosing component to the LRA header, but
        ;; MAKE-LISP-OBJ actually checks the value before we get a
        ;; chance to set it, so it's now done in arch-assem.S.
        ;; KLUDGE: The preceding concern is rendered irrelevant by
        ;; use of unsafe %MAKE-LISP-OBJ, but we do still copy the lisp header
        ;; from arch-assem.S which is horrible. Either that assembly code
        ;; should be emitted as Lisp asm routine so that it has access to
        ;; SB-VM:CODE-CONSTANTS-OFFSET, or we should emit the header.
        ;; The issue is that the backpointer (word count) from the LRA to
        ;; its containing code object has to be right.
        (setf (code-header-ref code-object real-lra-slot) real-lra)
        (values (with-pinned-objects (code-object)
                  (%make-lisp-obj (logior (sap-int (code-instructions code-object))
                                          sb-vm:other-pointer-lowtag)))
                (sb-vm:sanctify-for-execution code-object)
                (trap-offset))))))

;;;; miscellaneous

;;; This appears here because it cannot go with the DEBUG-FUN
;;; interface since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after
;;; the DEBUG-FUN routines.

;;; Return a code-location before the body of a function and after all
;;; the arguments are in place; or if that location can't be
;;; determined due to a lack of debug information, return NIL.
(defun debug-fun-start-location (debug-fun)
  (etypecase debug-fun
    (compiled-debug-fun
     (code-location-from-pc debug-fun
                            (sb-c::compiled-debug-fun-start-pc
                             (compiled-debug-fun-compiler-debug-fun
                              debug-fun))
                            nil))
    ;; (There used to be more cases back before sbcl-0.7.0, when
    ;; we did special tricks to debug the IR1 interpreter.)
    ))


;;;; Single-stepping

;;; The single-stepper works by inserting conditional trap instructions
;;; into the generated code (see src/compiler/*/call.lisp), currently:
;;;
;;;   1) Before the code generated for a function call that was
;;;      translated to a VOP
;;;   2) Just before the call instruction for a full call
;;;
;;; In both cases, the trap will only be executed if stepping has been
;;; enabled, in which case it'll ultimately be handled by
;;; HANDLE-SINGLE-STEP-TRAP, which will either signal a stepping condition,
;;; or replace the function that's about to be called with a wrapper
;;; which will signal the condition.

(defun handle-single-step-trap (kind callee-register-offset)
  (let ((context (nth-interrupt-context (1- *free-interrupt-context-index*))))
    ;; The following calls must get tail-call eliminated for
    ;; *STEP-FRAME* to get set correctly on non-x86.
    (if (= kind single-step-before-trap)
        (handle-single-step-before-trap context)
        (handle-single-step-around-trap context callee-register-offset))))

(defvar *step-frame* nil)

(defun handle-single-step-before-trap (context)
  (let ((step-info (single-step-info-from-context context)))
    ;; If there was not enough debug information available, there's no
    ;; sense in signaling the condition.
    (when step-info
      (let ((*step-frame*
             (signal-context-frame (sb-alien:alien-sap context))))
        (sb-impl::step-form step-info
                            ;; We could theoretically store information in
                            ;; the debug-info about to determine the
                            ;; arguments here, but for now let's just pass
                            ;; on it.
                            :unknown)))))

;;; This function will replace the fdefn / function that was in the
;;; register at CALLEE-REGISTER-OFFSET with a wrapper function. To
;;; ensure that the full call will use the wrapper instead of the
;;; original, conditional trap must be emitted before the fdefn /
;;; function is converted into a raw address.
(defun handle-single-step-around-trap (context callee-register-offset)
  ;; Fetch the function / fdefn we're about to call from the
  ;; appropriate register.
  (let* ((callee
           ;; FIXME: this could handle static calls, but needs some
           ;; help from the backends
          (make-lisp-obj
           (cond #+immobile-space
                 ((eql (sap-ref-8 (context-pc context) 0) #xB8) ; MOV EAX,imm
                  ;; Construct a properly tagged FDEFN given the value
                  ;; that machine code references it by for purposes
                  ;; of the ensuing CALL instruction.
                  ;; FIXME: this ought to go in {target}-vm.lisp as
                  ;; something like GET-FDEFN-FOR-SINGLE-STEP
                  (+ (sap-ref-32 (context-pc context) 1) -2 other-pointer-lowtag))
                 (t
                  (context-register context callee-register-offset)))))
         (step-info (single-step-info-from-context context)))
    ;; If there was not enough debug information available, there's no
    ;; sense in signaling the condition.
    (unless step-info
      (return-from handle-single-step-around-trap))
    (let* ((fun (lambda (&rest args)
                  (flet ((call ()
                           (apply (typecase callee
                                    (fdefn (fdefn-fun callee))
                                    (function callee))
                                  args)))
                    ;; Signal a step condition
                    (let* ((step-in
                             (let ((*step-frame* (frame-down (top-frame))))
                               (sb-impl::step-form step-info args))))
                      ;; And proceed based on its return value.
                      (if step-in
                          ;; STEP-INTO was selected. Use *STEP-OUT* to
                          ;; let the stepper know that selecting the
                          ;; STEP-OUT restart is valid inside this
                          (let ((sb-impl::*step-out* :maybe))
                            ;; Pass the return values of the call to
                            ;; STEP-VALUES, which will signal a
                            ;; condition with them in the VALUES slot.
                            (unwind-protect
                                 (multiple-value-call #'sb-impl::step-values
                                   step-info
                                   (call))
                              ;; If the user selected the STEP-OUT
                              ;; restart during the call, resume
                              ;; stepping
                              (when (eq sb-impl::*step-out* t)
                                (sb-impl::enable-stepping))))
                          ;; STEP-NEXT / CONTINUE / OUT selected:
                          ;; Disable the stepper for the duration of
                          ;; the call.
                          (sb-impl::with-stepping-disabled
                            (call)))))))
           (new-callee (etypecase callee
                         (fdefn
                          (let ((fdefn (make-fdefn (gensym))))
                            (setf (fdefn-fun fdefn) fun)
                            fdefn))
                         (function fun))))
      ;; And then store the wrapper in the same place.
      (with-pinned-objects (new-callee)
        ;; %SET-CONTEXT-REGISTER is a function, so the address of
        ;; NEW-CALLEE gets converted to a fixnum before passing, which
        ;; won't keep NEW-CALLEE pinned down. Once it's inside
        ;; CONTEXT, which is registered in thread->interrupt_contexts,
        ;; it will properly point to NEW-CALLEE.
        (cond
         #+immobile-code
         ((fdefn-p callee) ; as above, should be in {target}-vm.lisp
          ;; Store into RAX the necessary value for issuing a CALL to the JMP
          ;; opcode in the FDEFN header.
          (setf (context-register context callee-register-offset)
                (sb-vm::fdefn-entry-address new-callee))
          ;; And skip over the MOV EAX, imm instruction.
          (sb-vm::incf-context-pc context 5))
         (t
          (setf (context-register context callee-register-offset)
                (get-lisp-obj-address new-callee))))))))

;;; Given a signal context, fetch the step-info that's been stored in
;;; the debug info at the trap point.
(defun single-step-info-from-context (context)
  (multiple-value-bind (code pc-offset)
      (escaped-frame-from-context context)
    (let* ((debug-fun (debug-fun-from-pc code pc-offset))
           (location (code-location-from-pc debug-fun
                                            pc-offset
                                            nil)))
      (handler-case
          (progn
            (fill-in-code-location location)
            (code-location-debug-source location)
            (compiled-code-location-step-info location))
        (debug-condition ()
          nil)))))

;;; Return the frame that triggered a single-step condition. Used to
;;; provide a *STACK-TOP-HINT*.
(defun find-stepped-frame ()
  (or *step-frame*
      (top-frame)))

;;;; fetching errorful function name

;;; This flag is used to prevent infinite recursive lossage when
;;; we can't find the caller for some reason.
(defvar *finding-frame* nil)

(defun find-caller-frame ()
  (unless *finding-frame*
    (handler-case
        (let* ((*finding-frame* t)
               (frame (frame-down (frame-down (top-frame)))))
          (flush-frames-above frame)
          frame)
      ((or error debug-condition) ()))))

(defun find-interrupted-frame ()
  (when (plusp *free-interrupt-context-index*)
    (handler-case
        (signal-context-frame
         (sb-alien:alien-sap
          (nth-interrupt-context (1- *free-interrupt-context-index*))))
      ((or error debug-condition) ()))))

(defun find-caller-of-named-frame (name)
  (unless *finding-frame*
    (handler-case
        (let ((*finding-frame* t))
          (do ((frame (top-frame) (frame-down frame)))
              ((null frame))
            (when (and (compiled-frame-p frame)
                       (eq name (debug-fun-name
                                 (frame-debug-fun frame))))
              (let ((caller (frame-down frame)))
                (flush-frames-above caller)
                (return caller)))))
      ((or error debug-condition) ()))))
